From f2c6a34de9836ff9c2b3684f5ce19e08098f373e Mon Sep 17 00:00:00 2001 From: lilinjie Date: Mon, 24 Apr 2023 10:29:59 +0800 Subject: [PATCH 01/60] fix typo Signed-off-by: lilinjie --- GotoBLAS_06WeirdPerformance.txt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/GotoBLAS_06WeirdPerformance.txt b/GotoBLAS_06WeirdPerformance.txt index 05766e17b..0f7cec5c9 100644 --- a/GotoBLAS_06WeirdPerformance.txt +++ b/GotoBLAS_06WeirdPerformance.txt @@ -11,7 +11,7 @@ operation is finished. -2. Simlar problem may happen under virtual machine. If supervisor +2. Similar problem may happen under virtual machine. If supervisor allocates different cores for each scheduling, BLAS performnace will be bad. This is because BLAS also utilizes all cache, unexpected re-schedule for different core may result of heavy From d99aad8ee308600832da39105a6511275cfe32ad Mon Sep 17 00:00:00 2001 From: Chip-Kerchner Date: Tue, 14 Nov 2023 11:07:08 -0600 Subject: [PATCH 02/60] Fix older version of gcc - missing __has_builtin, cpuid and no support of P10. --- Makefile.power | 12 ++++++++++++ driver/others/dynamic_power.c | 17 ++++++++++++----- 2 files changed, 24 insertions(+), 5 deletions(-) diff --git a/Makefile.power b/Makefile.power index 95bada34f..aa1ca080a 100644 --- a/Makefile.power +++ b/Makefile.power @@ -11,7 +11,19 @@ endif ifeq ($(CORE), POWER10) ifneq ($(C_COMPILER), PGI) +ifeq ($(C_COMPILER), GCC)) +ifeq ($(GCCVERSIONGTEQ10), 1) CCOMMON_OPT += -Ofast -mcpu=power10 -mtune=power10 -mvsx -fno-fast-math +else ifneq ($(GCCVERSIONGT4), 1) +$(warning your compiler is too old to fully support POWER9, getting a newer version of gcc is recommended) +CCOMMON_OPT += -Ofast -mcpu=power8 -mtune=power8 -mvsx -fno-fast-math +else +$(warning your compiler is too old to fully support POWER10, getting a newer version of gcc is recommended) +CCOMMON_OPT += -Ofast -mcpu=power9 -mtune=power9 -mvsx -fno-fast-math +endif +else +CCOMMON_OPT += -Ofast -mcpu=power10 -mtune=power10 -mvsx -fno-fast-math +endif ifeq ($(F_COMPILER), IBM) FCOMMON_OPT += -O2 -qrecur -qnosave -qarch=pwr10 -qtune=pwr10 -qfloat=nomaf -qzerosize else diff --git a/driver/others/dynamic_power.c b/driver/others/dynamic_power.c index f0faf2baf..0454f186c 100644 --- a/driver/others/dynamic_power.c +++ b/driver/others/dynamic_power.c @@ -66,8 +66,7 @@ static int cpuid(void) #endif return CPU_UNKNOWN; } -#else -#if defined(C_PGI) || defined(__clang__) +#elif defined(C_PGI) || defined(__clang__) /* * NV HPC compilers do not yet implement __builtin_cpu_is(). * Fake a version here for use in the CPU detection code below. @@ -196,13 +195,21 @@ static int cpuid(void) cpu_type = pvrPOWER[i].cpu_type; return (int)(cpu_type); } -#endif /* C_PGI */ +#elif !defined(__BUILTIN_CPU_SUPPORTS__) +static int cpuid(void) +{ + return CPU_UNKNOWN; +} #endif /* _AIX */ #ifndef __BUILTIN_CPU_SUPPORTS__ #include -#if defined(_AIX) || (defined(__has_builtin) && !__has_builtin(__builtin_cpu_is)) +#ifndef __has_builtin +#define __has_builtin(x) 0 +#endif + +#if defined(_AIX) || !__has_builtin(__builtin_cpu_is) static int __builtin_cpu_is(const char *arg) { static int ipinfo = -1; @@ -227,7 +234,7 @@ static int __builtin_cpu_is(const char *arg) } #endif -#if defined(_AIX) || (defined(__has_builtin) && !__has_builtin(__builtin_cpu_supports)) +#if defined(_AIX) || !__has_builtin(__builtin_cpu_supports) static int __builtin_cpu_supports(const char *arg) { return 0; From 23cda457fb0306d0aba39c3e19a1ced3fa0116c9 Mon Sep 17 00:00:00 2001 From: Martin Kroeker Date: Wed, 15 Nov 2023 09:48:23 +0100 Subject: [PATCH 03/60] Implement truncated QR with pivoting (Reference-LAPACK PR 891) --- lapack-netlib/SRC/cgeqp3rk.f | 1091 ++++++++++++++++++++++++++++++++++ lapack-netlib/SRC/claqp2rk.f | 726 ++++++++++++++++++++++ lapack-netlib/SRC/claqp3rk.f | 947 +++++++++++++++++++++++++++++ lapack-netlib/SRC/dgeqp3rk.f | 1081 +++++++++++++++++++++++++++++++++ lapack-netlib/SRC/dlaqp2rk.f | 713 ++++++++++++++++++++++ lapack-netlib/SRC/dlaqp3rk.f | 935 +++++++++++++++++++++++++++++ lapack-netlib/SRC/ilaenv.f | 21 +- lapack-netlib/SRC/sgeqp3rk.f | 1081 +++++++++++++++++++++++++++++++++ lapack-netlib/SRC/slaqp2rk.f | 713 ++++++++++++++++++++++ lapack-netlib/SRC/slaqp3rk.f | 935 +++++++++++++++++++++++++++++ lapack-netlib/SRC/zgeqp3rk.f | 1091 ++++++++++++++++++++++++++++++++++ lapack-netlib/SRC/zlaqp2rk.f | 726 ++++++++++++++++++++++ lapack-netlib/SRC/zlaqp3rk.f | 947 +++++++++++++++++++++++++++++ 13 files changed, 11006 insertions(+), 1 deletion(-) create mode 100644 lapack-netlib/SRC/cgeqp3rk.f create mode 100644 lapack-netlib/SRC/claqp2rk.f create mode 100644 lapack-netlib/SRC/claqp3rk.f create mode 100644 lapack-netlib/SRC/dgeqp3rk.f create mode 100644 lapack-netlib/SRC/dlaqp2rk.f create mode 100644 lapack-netlib/SRC/dlaqp3rk.f create mode 100644 lapack-netlib/SRC/sgeqp3rk.f create mode 100644 lapack-netlib/SRC/slaqp2rk.f create mode 100644 lapack-netlib/SRC/slaqp3rk.f create mode 100644 lapack-netlib/SRC/zgeqp3rk.f create mode 100644 lapack-netlib/SRC/zlaqp2rk.f create mode 100644 lapack-netlib/SRC/zlaqp3rk.f diff --git a/lapack-netlib/SRC/cgeqp3rk.f b/lapack-netlib/SRC/cgeqp3rk.f new file mode 100644 index 000000000..70789e64f --- /dev/null +++ b/lapack-netlib/SRC/cgeqp3rk.f @@ -0,0 +1,1091 @@ +*> \brief \b CGEQP3RK computes a truncated Householder QR factorization with column pivoting of a complex m-by-n matrix A by using Level 3 BLAS and overwrites m-by-nrhs matrix B with Q**H * B. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download CGEQP3RK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE CGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, A, LDA, +* $ K, MAXC2NRMK, RELMAXC2NRMK, JPIV, TAU, +* $ WORK, LWORK, RWORK, IWORK, INFO ) +* IMPLICIT NONE +* +* .. Scalar Arguments .. +* INTEGER INFO, K, KMAX, LDA, LWORK, M, N, NRHS +* REAL ABSTOL, MAXC2NRMK, RELMAXC2NRMK, RELTOL +* .. +* .. Array Arguments .. +* INTEGER IWORK( * ), JPIV( * ) +* REAL RWORK( * ) +* COMPLEX A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CGEQP3RK performs two tasks simultaneously: +*> +*> Task 1: The routine computes a truncated (rank K) or full rank +*> Householder QR factorization with column pivoting of a complex +*> M-by-N matrix A using Level 3 BLAS. K is the number of columns +*> that were factorized, i.e. factorization rank of the +*> factor R, K <= min(M,N). +*> +*> A * P(K) = Q(K) * R(K) = +*> +*> = Q(K) * ( R11(K) R12(K) ) = Q(K) * ( R(K)_approx ) +*> ( 0 R22(K) ) ( 0 R(K)_residual ), +*> +*> where: +*> +*> P(K) is an N-by-N permutation matrix; +*> Q(K) is an M-by-M orthogonal matrix; +*> R(K)_approx = ( R11(K), R12(K) ) is a rank K approximation of the +*> full rank factor R with K-by-K upper-triangular +*> R11(K) and K-by-N rectangular R12(K). The diagonal +*> entries of R11(K) appear in non-increasing order +*> of absolute value, and absolute values of all of +*> them exceed the maximum column 2-norm of R22(K) +*> up to roundoff error. +*> R(K)_residual = R22(K) is the residual of a rank K approximation +*> of the full rank factor R. It is a +*> an (M-K)-by-(N-K) rectangular matrix; +*> 0 is a an (M-K)-by-K zero matrix. +*> +*> Task 2: At the same time, the routine overwrites a complex M-by-NRHS +*> matrix B with Q(K)**H * B using Level 3 BLAS. +*> +*> ===================================================================== +*> +*> The matrices A and B are stored on input in the array A as +*> the left and right blocks A(1:M,1:N) and A(1:M, N+1:N+NRHS) +*> respectively. +*> +*> N NRHS +*> array_A = M [ mat_A, mat_B ] +*> +*> The truncation criteria (i.e. when to stop the factorization) +*> can be any of the following: +*> +*> 1) The input parameter KMAX, the maximum number of columns +*> KMAX to factorize, i.e. the factorization rank is limited +*> to KMAX. If KMAX >= min(M,N), the criterion is not used. +*> +*> 2) The input parameter ABSTOL, the absolute tolerance for +*> the maximum column 2-norm of the residual matrix R22(K). This +*> means that the factorization stops if this norm is less or +*> equal to ABSTOL. If ABSTOL < 0.0, the criterion is not used. +*> +*> 3) The input parameter RELTOL, the tolerance for the maximum +*> column 2-norm matrix of the residual matrix R22(K) divided +*> by the maximum column 2-norm of the original matrix A, which +*> is equal to abs(R(1,1)). This means that the factorization stops +*> when the ratio of the maximum column 2-norm of R22(K) to +*> the maximum column 2-norm of A is less than or equal to RELTOL. +*> If RELTOL < 0.0, the criterion is not used. +*> +*> 4) In case both stopping criteria ABSTOL or RELTOL are not used, +*> and when the residual matrix R22(K) is a zero matrix in some +*> factorization step K. ( This stopping criterion is implicit. ) +*> +*> The algorithm stops when any of these conditions is first +*> satisfied, otherwise the whole matrix A is factorized. +*> +*> To factorize the whole matrix A, use the values +*> KMAX >= min(M,N), ABSTOL < 0.0 and RELTOL < 0.0. +*> +*> The routine returns: +*> a) Q(K), R(K)_approx = ( R11(K), R12(K) ), +*> R(K)_residual = R22(K), P(K), i.e. the resulting matrices +*> of the factorization; P(K) is represented by JPIV, +*> ( if K = min(M,N), R(K)_approx is the full factor R, +*> and there is no residual matrix R(K)_residual); +*> b) K, the number of columns that were factorized, +*> i.e. factorization rank; +*> c) MAXC2NRMK, the maximum column 2-norm of the residual +*> matrix R(K)_residual = R22(K), +*> ( if K = min(M,N), MAXC2NRMK = 0.0 ); +*> d) RELMAXC2NRMK equals MAXC2NRMK divided by MAXC2NRM, the maximum +*> column 2-norm of the original matrix A, which is equal +*> to abs(R(1,1)), ( if K = min(M,N), RELMAXC2NRMK = 0.0 ); +*> e) Q(K)**H * B, the matrix B with the orthogonal +*> transformation Q(K)**H applied on the left. +*> +*> The N-by-N permutation matrix P(K) is stored in a compact form in +*> the integer array JPIV. For 1 <= j <= N, column j +*> of the matrix A was interchanged with column JPIV(j). +*> +*> The M-by-M orthogonal matrix Q is represented as a product +*> of elementary Householder reflectors +*> +*> Q(K) = H(1) * H(2) * . . . * H(K), +*> +*> where K is the number of columns that were factorized. +*> +*> Each H(j) has the form +*> +*> H(j) = I - tau * v * v**H, +*> +*> where 1 <= j <= K and +*> I is an M-by-M identity matrix, +*> tau is a complex scalar, +*> v is a complex vector with v(1:j-1) = 0 and v(j) = 1. +*> +*> v(j+1:M) is stored on exit in A(j+1:M,j) and tau in TAU(j). +*> +*> See the Further Details section for more information. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e. the number of +*> columns of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in] KMAX +*> \verbatim +*> KMAX is INTEGER +*> +*> The first factorization stopping criterion. KMAX >= 0. +*> +*> The maximum number of columns of the matrix A to factorize, +*> i.e. the maximum factorization rank. +*> +*> a) If KMAX >= min(M,N), then this stopping criterion +*> is not used, the routine factorizes columns +*> depending on ABSTOL and RELTOL. +*> +*> b) If KMAX = 0, then this stopping criterion is +*> satisfied on input and the routine exits immediately. +*> This means that the factorization is not performed, +*> the matrices A and B are not modified, and +*> the matrix A is itself the residual. +*> \endverbatim +*> +*> \param[in] ABSTOL +*> \verbatim +*> ABSTOL is REAL +*> +*> The second factorization stopping criterion, cannot be NaN. +*> +*> The absolute tolerance (stopping threshold) for +*> maximum column 2-norm of the residual matrix R22(K). +*> The algorithm converges (stops the factorization) when +*> the maximum column 2-norm of the residual matrix R22(K) +*> is less than or equal to ABSTOL. Let SAFMIN = DLAMCH('S'). +*> +*> a) If ABSTOL is NaN, then no computation is performed +*> and an error message ( INFO = -5 ) is issued +*> by XERBLA. +*> +*> b) If ABSTOL < 0.0, then this stopping criterion is not +*> used, the routine factorizes columns depending +*> on KMAX and RELTOL. +*> This includes the case ABSTOL = -Inf. +*> +*> c) If 0.0 <= ABSTOL < 2*SAFMIN, then ABSTOL = 2*SAFMIN +*> is used. This includes the case ABSTOL = -0.0. +*> +*> d) If 2*SAFMIN <= ABSTOL then the input value +*> of ABSTOL is used. +*> +*> Let MAXC2NRM be the maximum column 2-norm of the +*> whole original matrix A. +*> If ABSTOL chosen above is >= MAXC2NRM, then this +*> stopping criterion is satisfied on input and routine exits +*> immediately after MAXC2NRM is computed. The routine +*> returns MAXC2NRM in MAXC2NORMK, +*> and 1.0 in RELMAXC2NORMK. +*> This includes the case ABSTOL = +Inf. This means that the +*> factorization is not performed, the matrices A and B are not +*> modified, and the matrix A is itself the residual. +*> \endverbatim +*> +*> \param[in] RELTOL +*> \verbatim +*> RELTOL is REAL +*> +*> The third factorization stopping criterion, cannot be NaN. +*> +*> The tolerance (stopping threshold) for the ratio +*> abs(R(K+1,K+1))/abs(R(1,1)) of the maximum column 2-norm of +*> the residual matrix R22(K) to the maximum column 2-norm of +*> the original matrix A. The algorithm converges (stops the +*> factorization), when abs(R(K+1,K+1))/abs(R(1,1)) A is less +*> than or equal to RELTOL. Let EPS = DLAMCH('E'). +*> +*> a) If RELTOL is NaN, then no computation is performed +*> and an error message ( INFO = -6 ) is issued +*> by XERBLA. +*> +*> b) If RELTOL < 0.0, then this stopping criterion is not +*> used, the routine factorizes columns depending +*> on KMAX and ABSTOL. +*> This includes the case RELTOL = -Inf. +*> +*> c) If 0.0 <= RELTOL < EPS, then RELTOL = EPS is used. +*> This includes the case RELTOL = -0.0. +*> +*> d) If EPS <= RELTOL then the input value of RELTOL +*> is used. +*> +*> Let MAXC2NRM be the maximum column 2-norm of the +*> whole original matrix A. +*> If RELTOL chosen above is >= 1.0, then this stopping +*> criterion is satisfied on input and routine exits +*> immediately after MAXC2NRM is computed. +*> The routine returns MAXC2NRM in MAXC2NORMK, +*> and 1.0 in RELMAXC2NORMK. +*> This includes the case RELTOL = +Inf. This means that the +*> factorization is not performed, the matrices A and B are not +*> modified, and the matrix A is itself the residual. +*> +*> NOTE: We recommend that RELTOL satisfy +*> min( 10*max(M,N)*EPS, sqrt(EPS) ) <= RELTOL +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX array, dimension (LDA,N+NRHS) +*> +*> On entry: +*> +*> a) The subarray A(1:M,1:N) contains the M-by-N matrix A. +*> b) The subarray A(1:M,N+1:N+NRHS) contains the M-by-NRHS +*> matrix B. +*> +*> N NRHS +*> array_A = M [ mat_A, mat_B ] +*> +*> On exit: +*> +*> a) The subarray A(1:M,1:N) contains parts of the factors +*> of the matrix A: +*> +*> 1) If K = 0, A(1:M,1:N) contains the original matrix A. +*> 2) If K > 0, A(1:M,1:N) contains parts of the +*> factors: +*> +*> 1. The elements below the diagonal of the subarray +*> A(1:M,1:K) together with TAU(1:K) represent the +*> orthogonal matrix Q(K) as a product of K Householder +*> elementary reflectors. +*> +*> 2. The elements on and above the diagonal of +*> the subarray A(1:K,1:N) contain K-by-N +*> upper-trapezoidal matrix +*> R(K)_approx = ( R11(K), R12(K) ). +*> NOTE: If K=min(M,N), i.e. full rank factorization, +*> then R_approx(K) is the full factor R which +*> is upper-trapezoidal. If, in addition, M>=N, +*> then R is upper-triangular. +*> +*> 3. The subarray A(K+1:M,K+1:N) contains (M-K)-by-(N-K) +*> rectangular matrix R(K)_residual = R22(K). +*> +*> b) If NRHS > 0, the subarray A(1:M,N+1:N+NRHS) contains +*> the M-by-NRHS product Q(K)**H * B. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> This is the leading dimension for both matrices, A and B. +*> \endverbatim +*> +*> \param[out] K +*> \verbatim +*> K is INTEGER +*> Factorization rank of the matrix A, i.e. the rank of +*> the factor R, which is the same as the number of non-zero +*> rows of the factor R. 0 <= K <= min(M,KMAX,N). +*> +*> K also represents the number of non-zero Householder +*> vectors. +*> +*> NOTE: If K = 0, a) the arrays A and B are not modified; +*> b) the array TAU(1:min(M,N)) is set to ZERO, +*> if the matrix A does not contain NaN, +*> otherwise the elements TAU(1:min(M,N)) +*> are undefined; +*> c) the elements of the array JPIV are set +*> as follows: for j = 1:N, JPIV(j) = j. +*> \endverbatim +*> +*> \param[out] MAXC2NRMK +*> \verbatim +*> MAXC2NRMK is REAL +*> The maximum column 2-norm of the residual matrix R22(K), +*> when the factorization stopped at rank K. MAXC2NRMK >= 0. +*> +*> a) If K = 0, i.e. the factorization was not performed, +*> the matrix A was not modified and is itself a residual +*> matrix, then MAXC2NRMK equals the maximum column 2-norm +*> of the original matrix A. +*> +*> b) If 0 < K < min(M,N), then MAXC2NRMK is returned. +*> +*> c) If K = min(M,N), i.e. the whole matrix A was +*> factorized and there is no residual matrix, +*> then MAXC2NRMK = 0.0. +*> +*> NOTE: MAXC2NRMK in the factorization step K would equal +*> R(K+1,K+1) in the next factorization step K+1. +*> \endverbatim +*> +*> \param[out] RELMAXC2NRMK +*> \verbatim +*> RELMAXC2NRMK is REAL +*> The ratio MAXC2NRMK / MAXC2NRM of the maximum column +*> 2-norm of the residual matrix R22(K) (when the factorization +*> stopped at rank K) to the maximum column 2-norm of the +*> whole original matrix A. RELMAXC2NRMK >= 0. +*> +*> a) If K = 0, i.e. the factorization was not performed, +*> the matrix A was not modified and is itself a residual +*> matrix, then RELMAXC2NRMK = 1.0. +*> +*> b) If 0 < K < min(M,N), then +*> RELMAXC2NRMK = MAXC2NRMK / MAXC2NRM is returned. +*> +*> c) If K = min(M,N), i.e. the whole matrix A was +*> factorized and there is no residual matrix, +*> then RELMAXC2NRMK = 0.0. +*> +*> NOTE: RELMAXC2NRMK in the factorization step K would equal +*> abs(R(K+1,K+1))/abs(R(1,1)) in the next factorization +*> step K+1. +*> \endverbatim +*> +*> \param[out] JPIV +*> \verbatim +*> JPIV is INTEGER array, dimension (N) +*> Column pivot indices. For 1 <= j <= N, column j +*> of the matrix A was interchanged with column JPIV(j). +*> +*> The elements of the array JPIV(1:N) are always set +*> by the routine, for example, even when no columns +*> were factorized, i.e. when K = 0, the elements are +*> set as JPIV(j) = j for j = 1:N. +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is COMPLEX array, dimension (min(M,N)) +*> The scalar factors of the elementary reflectors. +*> +*> If 0 < K <= min(M,N), only the elements TAU(1:K) of +*> the array TAU are modified by the factorization. +*> After the factorization computed, if no NaN was found +*> during the factorization, the remaining elements +*> TAU(K+1:min(M,N)) are set to zero, otherwise the +*> elements TAU(K+1:min(M,N)) are not set and therefore +*> undefined. +*> ( If K = 0, all elements of TAU are set to zero, if +*> the matrix A does not contain NaN. ) +*> \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 dimension of the array WORK. +*. LWORK >= N+NRHS-1 +*> For optimal performance LWORK >= NB*( N+NRHS+1 ), +*> where NB is the optimal block size for CGEQP3RK returned +*> by ILAENV. Minimal block size MINNB=2. +*> +*> NOTE: The decision, whether to use unblocked BLAS 2 +*> or blocked BLAS 3 code is based not only on the dimension +*> LWORK of the availbale workspace WORK, but also also on the +*> matrix A dimension N via crossover point NX returned +*> by ILAENV. (For N less than NX, unblocked code should be +*> used.) +*> +*> 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] RWORK +*> \verbatim +*> RWORK is REAL array, dimension (2*N) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (N-1). +*> Is a work array. ( IWORK is used to store indices +*> of "bad" columns for norm downdating in the residual +*> matrix in the blocked step auxiliary subroutine CLAQP3RK ). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> 1) INFO = 0: successful exit. +*> 2) INFO < 0: if INFO = -i, the i-th argument had an +*> illegal value. +*> 3) If INFO = j_1, where 1 <= j_1 <= N, then NaN was +*> detected and the routine stops the computation. +*> The j_1-th column of the matrix A or the j_1-th +*> element of array TAU contains the first occurrence +*> of NaN in the factorization step K+1 ( when K columns +*> have been factorized ). +*> +*> On exit: +*> K is set to the number of +*> factorized columns without +*> exception. +*> MAXC2NRMK is set to NaN. +*> RELMAXC2NRMK is set to NaN. +*> TAU(K+1:min(M,N)) is not set and contains undefined +*> elements. If j_1=K+1, TAU(K+1) +*> may contain NaN. +*> 4) If INFO = j_2, where N+1 <= j_2 <= 2*N, then no NaN +*> was detected, but +Inf (or -Inf) was detected and +*> the routine continues the computation until completion. +*> The (j_2-N)-th column of the matrix A contains the first +*> occurrence of +Inf (or -Inf) in the factorization +*> step K+1 ( when K columns have been factorized ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup geqp3rk +* +*> \par Further Details: +* ===================== +* +*> \verbatim +*> CGEQP3RK is based on the same BLAS3 Householder QR factorization +*> algorithm with column pivoting as in CGEQP3 routine which uses +*> CLARFG routine to generate Householder reflectors +*> for QR factorization. +*> +*> We can also write: +*> +*> A = A_approx(K) + A_residual(K) +*> +*> The low rank approximation matrix A(K)_approx from +*> the truncated QR factorization of rank K of the matrix A is: +*> +*> A(K)_approx = Q(K) * ( R(K)_approx ) * P(K)**T +*> ( 0 0 ) +*> +*> = Q(K) * ( R11(K) R12(K) ) * P(K)**T +*> ( 0 0 ) +*> +*> The residual A_residual(K) of the matrix A is: +*> +*> A_residual(K) = Q(K) * ( 0 0 ) * P(K)**T = +*> ( 0 R(K)_residual ) +*> +*> = Q(K) * ( 0 0 ) * P(K)**T +*> ( 0 R22(K) ) +*> +*> The truncated (rank K) factorization guarantees that +*> the maximum column 2-norm of A_residual(K) is less than +*> or equal to MAXC2NRMK up to roundoff error. +*> +*> NOTE: An approximation of the null vectors +*> of A can be easily computed from R11(K) +*> and R12(K): +*> +*> Null( A(K) )_approx = P * ( inv(R11(K)) * R12(K) ) +*> ( -I ) +*> +*> \endverbatim +* +*> \par References: +* ================ +*> [1] A Level 3 BLAS QR factorization algorithm with column pivoting developed in 1996. +*> G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain. +*> X. Sun, Computer Science Dept., Duke University, USA. +*> C. H. Bischof, Math. and Comp. Sci. Div., Argonne National Lab, USA. +*> A BLAS-3 version of the QR factorization with column pivoting. +*> LAPACK Working Note 114 +*> \htmlonly +*> https://www.netlib.org/lapack/lawnspdf/lawn114.pdf +*> \endhtmlonly +*> and in +*> SIAM J. Sci. Comput., 19(5):1486-1494, Sept. 1998. +*> \htmlonly +*> https://doi.org/10.1137/S1064827595296732 +*> \endhtmlonly +*> +*> [2] A partial column norm updating strategy developed in 2006. +*> Z. Drmac and Z. Bujanovic, Dept. of Math., University of Zagreb, Croatia. +*> On the failure of rank revealing QR factorization software – a case study. +*> LAPACK Working Note 176. +*> \htmlonly +*> http://www.netlib.org/lapack/lawnspdf/lawn176.pdf +*> \endhtmlonly +*> and in +*> ACM Trans. Math. Softw. 35, 2, Article 12 (July 2008), 28 pages. +*> \htmlonly +*> https://doi.org/10.1145/1377612.1377616 +*> \endhtmlonly +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> November 2023, Igor Kozachenko, James Demmel, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE CGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, A, LDA, + $ K, MAXC2NRMK, RELMAXC2NRMK, JPIV, TAU, + $ WORK, LWORK, RWORK, IWORK, INFO ) + IMPLICIT NONE +* +* -- LAPACK computational routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER INFO, K, KF, KMAX, LDA, LWORK, M, N, NRHS + REAL ABSTOL, MAXC2NRMK, RELMAXC2NRMK, RELTOL +* .. +* .. Array Arguments .. + INTEGER IWORK( * ), JPIV( * ) + REAL RWORK( * ) + COMPLEX A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER INB, INBMIN, IXOVER + PARAMETER ( INB = 1, INBMIN = 2, IXOVER = 3 ) + REAL ZERO, ONE, TWO + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0, TWO = 2.0E+0 ) + COMPLEX CZERO + PARAMETER ( CZERO = ( 0.0E+0, 0.0E+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY, DONE + INTEGER IINFO, IOFFSET, IWS, J, JB, JBF, JMAXB, JMAX, + $ JMAXC2NRM, KP1, LWKOPT, MINMN, N_SUB, NB, + $ NBMIN, NX + REAL EPS, HUGEVAL, MAXC2NRM, SAFMIN +* .. +* .. External Subroutines .. + EXTERNAL CLAQP2RK, CLAQP3RK, XERBLA +* .. +* .. External Functions .. + LOGICAL SISNAN + INTEGER ISAMAX, ILAENV + REAL SLAMCH, SCNRM2 + EXTERNAL SISNAN, SLAMCH, SCNRM2, ISAMAX, ILAENV +* .. +* .. Intrinsic Functions .. + INTRINSIC CMPLX, MAX, MIN +* .. +* .. Executable Statements .. +* +* Test input arguments +* ==================== +* + INFO = 0 + LQUERY = ( LWORK.EQ.-1 ) + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -3 + ELSE IF( KMAX.LT.0 ) THEN + INFO = -4 + ELSE IF( SISNAN( ABSTOL ) ) THEN + INFO = -5 + ELSE IF( SISNAN( RELTOL ) ) THEN + INFO = -6 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -8 + END IF +* +* If the input parameters M, N, NRHS, KMAX, LDA are valid: +* a) Test the input workspace size LWORK for the minimum +* size requirement IWS. +* b) Determine the optimal block size NB and optimal +* workspace size LWKOPT to be returned in WORK(1) +* in case of (1) LWORK < IWS, (2) LQUERY = .TRUE., +* (3) when routine exits. +* Here, IWS is the miminum workspace required for unblocked +* code. +* + IF( INFO.EQ.0 ) THEN + MINMN = MIN( M, N ) + IF( MINMN.EQ.0 ) THEN + IWS = 1 + LWKOPT = 1 + ELSE +* +* Minimal workspace size in case of using only unblocked +* BLAS 2 code in CLAQP2RK. +* 1) CLAQP2RK: N+NRHS-1 to use in WORK array that is used +* in CLARF subroutine inside CLAQP2RK to apply an +* elementary reflector from the left. +* TOTAL_WORK_SIZE = 3*N + NRHS - 1 +* + IWS = N + NRHS - 1 +* +* Assign to NB optimal block size. +* + NB = ILAENV( INB, 'CGEQP3RK', ' ', M, N, -1, -1 ) +* +* A formula for the optimal workspace size in case of using +* both unblocked BLAS 2 in CLAQP2RK and blocked BLAS 3 code +* in CLAQP3RK. +* 1) CGEQP3RK, CLAQP2RK, CLAQP3RK: 2*N to store full and +* partial column 2-norms. +* 2) CLAQP2RK: N+NRHS-1 to use in WORK array that is used +* in CLARF subroutine to apply an elementary reflector +* from the left. +* 3) CLAQP3RK: NB*(N+NRHS) to use in the work array F that +* is used to apply a block reflector from +* the left. +* 4) CLAQP3RK: NB to use in the auxilixary array AUX. +* Sizes (2) and ((3) + (4)) should intersect, therefore +* TOTAL_WORK_SIZE = 2*N + NB*( N+NRHS+1 ), given NBMIN=2. +* + LWKOPT = 2*N + NB*( N+NRHS+1 ) + END IF + WORK( 1 ) = CMPLX( LWKOPT ) +* + IF( ( LWORK.LT.IWS ) .AND. .NOT.LQUERY ) THEN + INFO = -15 + END IF + END IF +* +* NOTE: The optimal workspace size is returned in WORK(1), if +* the input parameters M, N, NRHS, KMAX, LDA are valid. +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CGEQP3RK', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible for M=0 or N=0. +* + IF( MINMN.EQ.0 ) THEN + K = 0 + MAXC2NRMK = ZERO + RELMAXC2NRMK = ZERO + WORK( 1 ) = CMPLX( LWKOPT ) + RETURN + END IF +* +* ================================================================== +* +* Initialize column pivot array JPIV. +* + DO J = 1, N + JPIV( J ) = J + END DO +* +* ================================================================== +* +* Initialize storage for partial and exact column 2-norms. +* a) The elements WORK(1:N) are used to store partial column +* 2-norms of the matrix A, and may decrease in each computation +* step; initialize to the values of complete columns 2-norms. +* b) The elements WORK(N+1:2*N) are used to store complete column +* 2-norms of the matrix A, they are not changed during the +* computation; initialize the values of complete columns 2-norms. +* + DO J = 1, N + RWORK( J ) = SCNRM2( M, A( 1, J ), 1 ) + RWORK( N+J ) = RWORK( J ) + END DO +* +* ================================================================== +* +* Compute the pivot column index and the maximum column 2-norm +* for the whole original matrix stored in A(1:M,1:N). +* + KP1 = ISAMAX( N, RWORK( 1 ), 1 ) +* +* ==================================================================. +* + IF( SISNAN( MAXC2NRM ) ) THEN +* +* Check if the matrix A contains NaN, set INFO parameter +* to the column number where the first NaN is found and return +* from the routine. +* + K = 0 + INFO = KP1 +* +* Set MAXC2NRMK and RELMAXC2NRMK to NaN. +* + MAXC2NRMK = MAXC2NRM + RELMAXC2NRMK = MAXC2NRM +* +* Array TAU is not set and contains undefined elements. +* + WORK( 1 ) = CMPLX( LWKOPT ) + RETURN + END IF +* +* =================================================================== +* + IF( MAXC2NRM.EQ.ZERO ) THEN +* +* Check is the matrix A is a zero matrix, set array TAU and +* return from the routine. +* + K = 0 + MAXC2NRMK = ZERO + RELMAXC2NRMK = ZERO +* + DO J = 1, MINMN + TAU( J ) = CZERO + END DO +* + WORK( 1 ) = CMPLX( LWKOPT ) + RETURN +* + END IF +* +* =================================================================== +* + HUGEVAL = SLAMCH( 'Overflow' ) +* + IF( MAXC2NRM.GT.HUGEVAL ) THEN +* +* Check if the matrix A contains +Inf or -Inf, set INFO parameter +* to the column number, where the first +/-Inf is found plus N, +* and continue the computation. +* + INFO = N + KP1 +* + END IF +* +* ================================================================== +* +* Quick return if possible for the case when the first +* stopping criterion is satisfied, i.e. KMAX = 0. +* + IF( KMAX.EQ.0 ) THEN + K = 0 + MAXC2NRMK = MAXC2NRM + RELMAXC2NRMK = ONE + DO J = 1, MINMN + TAU( J ) = CZERO + END DO + WORK( 1 ) = CMPLX( LWKOPT ) + RETURN + END IF +* +* ================================================================== +* + EPS = SLAMCH('Epsilon') +* +* Adjust ABSTOL +* + IF( ABSTOL.GE.ZERO ) THEN + SAFMIN = SLAMCH('Safe minimum') + ABSTOL = MAX( ABSTOL, TWO*SAFMIN ) + END IF +* +* Adjust RELTOL +* + IF( RELTOL.GE.ZERO ) THEN + RELTOL = MAX( RELTOL, EPS ) + END IF +* +* =================================================================== +* +* JMAX is the maximum index of the column to be factorized, +* which is also limited by the first stopping criterion KMAX. +* + JMAX = MIN( KMAX, MINMN ) +* +* =================================================================== +* +* Quick return if possible for the case when the second or third +* stopping criterion for the whole original matrix is satified, +* i.e. MAXC2NRM <= ABSTOL or RELMAXC2NRM <= RELTOL +* (which is ONE <= RELTOL). +* + IF( MAXC2NRM.LE.ABSTOL .OR. ONE.LE.RELTOL ) THEN +* + K = 0 + MAXC2NRMK = MAXC2NRM + RELMAXC2NRMK = ONE +* + DO J = 1, MINMN + TAU( J ) = CZERO + END DO +* + WORK( 1 ) = CMPLX( LWKOPT ) + RETURN + END IF +* +* ================================================================== +* Factorize columns +* ================================================================== +* +* Determine the block size. +* + NBMIN = 2 + NX = 0 +* + IF( ( NB.GT.1 ) .AND. ( NB.LT.MINMN ) ) THEN +* +* Determine when to cross over from blocked to unblocked code. +* (for N less than NX, unblocked code should be used). +* + NX = MAX( 0, ILAENV( IXOVER, 'CGEQP3RK', ' ', M, N, -1, -1 ) ) +* + IF( NX.LT.MINMN ) THEN +* +* Determine if workspace is large enough for blocked code. +* + IF( LWORK.LT.LWKOPT ) THEN +* +* Not enough workspace to use optimal block size that +* is currently stored in NB. +* Reduce NB and determine the minimum value of NB. +* + NB = ( LWORK-2*N ) / ( N+1 ) + NBMIN = MAX( 2, ILAENV( INBMIN, 'CGEQP3RK', ' ', M, N, + $ -1, -1 ) ) +* + END IF + END IF + END IF +* +* ================================================================== +* +* DONE is the boolean flag to rerpresent the case when the +* factorization completed in the block factorization routine, +* before the end of the block. +* + DONE = .FALSE. +* +* J is the column index. +* + J = 1 +* +* (1) Use blocked code initially. +* +* JMAXB is the maximum column index of the block, when the +* blocked code is used, is also limited by the first stopping +* criterion KMAX. +* + JMAXB = MIN( KMAX, MINMN - NX ) +* + IF( NB.GE.NBMIN .AND. NB.LT.JMAX .AND. JMAXB.GT.0 ) THEN +* +* Loop over the column blocks of the matrix A(1:M,1:JMAXB). Here: +* J is the column index of a column block; +* JB is the column block size to pass to block factorization +* routine in a loop step; +* JBF is the number of columns that were actually factorized +* that was returned by the block factorization routine +* in a loop step, JBF <= JB; +* N_SUB is the number of columns in the submatrix; +* IOFFSET is the number of rows that should not be factorized. +* + DO WHILE( J.LE.JMAXB ) +* + JB = MIN( NB, JMAXB-J+1 ) + N_SUB = N-J+1 + IOFFSET = J-1 +* +* Factorize JB columns among the columns A(J:N). +* + CALL CLAQP3RK( M, N_SUB, NRHS, IOFFSET, JB, ABSTOL, + $ RELTOL, KP1, MAXC2NRM, A( 1, J ), LDA, + $ DONE, JBF, MAXC2NRMK, RELMAXC2NRMK, + $ JPIV( J ), TAU( J ), + $ RWORK( J ), RWORK( N+J ), + $ WORK( 1 ), WORK( JB+1 ), + $ N+NRHS-J+1, IWORK, IINFO ) +* +* Set INFO on the first occurence of Inf. +* + IF( IINFO.GT.N_SUB .AND. INFO.EQ.0 ) THEN + INFO = 2*IOFFSET + IINFO + END IF +* + IF( DONE ) THEN +* +* Either the submatrix is zero before the end of the +* column block, or ABSTOL or RELTOL criterion is +* satisfied before the end of the column block, we can +* return from the routine. Perform the following before +* returning: +* a) Set the number of factorized columns K, +* K = IOFFSET + JBF from the last call of blocked +* routine. +* NOTE: 1) MAXC2NRMK and RELMAXC2NRMK are returned +* by the block factorization routine; +* 2) The remaining TAUs are set to ZERO by the +* block factorization routine. +* + K = IOFFSET + JBF +* +* Set INFO on the first occurrence of NaN, NaN takes +* prcedence over Inf. +* + IF( IINFO.LE.N_SUB .AND. IINFO.GT.0 ) THEN + INFO = IOFFSET + IINFO + END IF +* +* Return from the routine. +* + WORK( 1 ) = CMPLX( LWKOPT ) +* + RETURN +* + END IF +* + J = J + JBF +* + END DO +* + END IF +* +* Use unblocked code to factor the last or only block. +* J = JMAX+1 means we factorized the maximum possible number of +* columns, that is in ELSE clause we need to compute +* the MAXC2NORM and RELMAXC2NORM to return after we processed +* the blocks. +* + IF( J.LE.JMAX ) THEN +* +* N_SUB is the number of columns in the submatrix; +* IOFFSET is the number of rows that should not be factorized. +* + N_SUB = N-J+1 + IOFFSET = J-1 +* + CALL CLAQP2RK( M, N_SUB, NRHS, IOFFSET, JMAX-J+1, + $ ABSTOL, RELTOL, KP1, MAXC2NRM, A( 1, J ), LDA, + $ KF, MAXC2NRMK, RELMAXC2NRMK, JPIV( J ), + $ TAU( J ), RWORK( J ), RWORK( N+J ), + $ WORK( 1 ), IINFO ) +* +* ABSTOL or RELTOL criterion is satisfied when the number of +* the factorized columns KF is smaller then the number +* of columns JMAX-J+1 supplied to be factorized by the +* unblocked routine, we can return from +* the routine. Perform the following before returning: +* a) Set the number of factorized columns K, +* b) MAXC2NRMK and RELMAXC2NRMK are returned by the +* unblocked factorization routine above. +* + K = J - 1 + KF +* +* Set INFO on the first exception occurence. +* +* Set INFO on the first exception occurence of Inf or NaN, +* (NaN takes precedence over Inf). +* + IF( IINFO.GT.N_SUB .AND. INFO.EQ.0 ) THEN + INFO = 2*IOFFSET + IINFO + ELSE IF( IINFO.LE.N_SUB .AND. IINFO.GT.0 ) THEN + INFO = IOFFSET + IINFO + END IF +* + ELSE +* +* Compute the return values for blocked code. +* +* Set the number of factorized columns if the unblocked routine +* was not called. +* + K = JMAX +* +* If there exits a residual matrix after the blocked code: +* 1) compute the values of MAXC2NRMK, RELMAXC2NRMK of the +* residual matrix, otherwise set them to ZERO; +* 2) Set TAU(K+1:MINMN) to ZERO. +* + IF( K.LT.MINMN ) THEN + JMAXC2NRM = K + ISAMAX( N-K, RWORK( K+1 ), 1 ) + MAXC2NRMK = RWORK( JMAXC2NRM ) + IF( K.EQ.0 ) THEN + RELMAXC2NRMK = ONE + ELSE + RELMAXC2NRMK = MAXC2NRMK / MAXC2NRM + END IF +* + DO J = K + 1, MINMN + TAU( J ) = CZERO + END DO +* + ELSE + MAXC2NRMK = ZERO + RELMAXC2NRMK = ZERO +* + END IF +* +* END IF( J.LE.JMAX ) THEN +* + END IF +* + WORK( 1 ) = CMPLX( LWKOPT ) +* + RETURN +* +* End of CGEQP3RK +* + END diff --git a/lapack-netlib/SRC/claqp2rk.f b/lapack-netlib/SRC/claqp2rk.f new file mode 100644 index 000000000..073ad0f88 --- /dev/null +++ b/lapack-netlib/SRC/claqp2rk.f @@ -0,0 +1,726 @@ +*> \brief \b CLAQP2RK computes truncated QR factorization with column pivoting of a complex matrix block using Level 2 BLAS and overwrites a complex m-by-nrhs matrix B with Q**H * B. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download CLAQP2RK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE CLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, +* $ KP1, MAXC2NRM, A, LDA, K, MAXC2NRMK, +* $ RELMAXC2NRMK, JPIV, TAU, VN1, VN2, WORK, +* $ INFO ) +* IMPLICIT NONE +* +* .. Scalar Arguments .. +* INTEGER INFO, IOFFSET, KP1, K, KMAX, LDA, M, N, NRHS +* REAL ABSTOL, MAXC2NRM, MAXC2NRMK, RELMAXC2NRMK, +* $ RELTOL +* .. +* .. Array Arguments .. +* INTEGER JPIV( * ) +* REAL VN1( * ), VN2( * ) +* COMPLEX A( LDA, * ), TAU( * ), WORK( * ) +* $ +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CLAQP2RK computes a truncated (rank K) or full rank Householder QR +*> factorization with column pivoting of the complex matrix +*> block A(IOFFSET+1:M,1:N) as +*> +*> A * P(K) = Q(K) * R(K). +*> +*> The routine uses Level 2 BLAS. The block A(1:IOFFSET,1:N) +*> is accordingly pivoted, but not factorized. +*> +*> The routine also overwrites the right-hand-sides matrix block B +*> stored in A(IOFFSET+1:M,N+1:N+NRHS) with Q(K)**H * B. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of +*> columns of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in] IOFFSET +*> \verbatim +*> IOFFSET is INTEGER +*> The number of rows of the matrix A that must be pivoted +*> but not factorized. IOFFSET >= 0. +*> +*> IOFFSET also represents the number of columns of the whole +*> original matrix A_orig that have been factorized +*> in the previous steps. +*> \endverbatim +*> +*> \param[in] KMAX +*> \verbatim +*> KMAX is INTEGER +*> +*> The first factorization stopping criterion. KMAX >= 0. +*> +*> The maximum number of columns of the matrix A to factorize, +*> i.e. the maximum factorization rank. +*> +*> a) If KMAX >= min(M-IOFFSET,N), then this stopping +*> criterion is not used, factorize columns +*> depending on ABSTOL and RELTOL. +*> +*> b) If KMAX = 0, then this stopping criterion is +*> satisfied on input and the routine exits immediately. +*> This means that the factorization is not performed, +*> the matrices A and B and the arrays TAU, IPIV +*> are not modified. +*> \endverbatim +*> +*> \param[in] ABSTOL +*> \verbatim +*> ABSTOL is REAL, cannot be NaN. +*> +*> The second factorization stopping criterion. +*> +*> The absolute tolerance (stopping threshold) for +*> maximum column 2-norm of the residual matrix. +*> The algorithm converges (stops the factorization) when +*> the maximum column 2-norm of the residual matrix +*> is less than or equal to ABSTOL. +*> +*> a) If ABSTOL < 0.0, then this stopping criterion is not +*> used, the routine factorizes columns depending +*> on KMAX and RELTOL. +*> This includes the case ABSTOL = -Inf. +*> +*> b) If 0.0 <= ABSTOL then the input value +*> of ABSTOL is used. +*> \endverbatim +*> +*> \param[in] RELTOL +*> \verbatim +*> RELTOL is REAL, cannot be NaN. +*> +*> The third factorization stopping criterion. +*> +*> The tolerance (stopping threshold) for the ratio of the +*> maximum column 2-norm of the residual matrix to the maximum +*> column 2-norm of the original matrix A_orig. The algorithm +*> converges (stops the factorization), when this ratio is +*> less than or equal to RELTOL. +*> +*> a) If RELTOL < 0.0, then this stopping criterion is not +*> used, the routine factorizes columns depending +*> on KMAX and ABSTOL. +*> This includes the case RELTOL = -Inf. +*> +*> d) If 0.0 <= RELTOL then the input value of RELTOL +*> is used. +*> \endverbatim +*> +*> \param[in] KP1 +*> \verbatim +*> KP1 is INTEGER +*> The index of the column with the maximum 2-norm in +*> the whole original matrix A_orig determined in the +*> main routine CGEQP3RK. 1 <= KP1 <= N_orig_mat. +*> \endverbatim +*> +*> \param[in] MAXC2NRM +*> \verbatim +*> MAXC2NRM is REAL +*> The maximum column 2-norm of the whole original +*> matrix A_orig computed in the main routine CGEQP3RK. +*> MAXC2NRM >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX array, dimension (LDA,N+NRHS) +*> On entry: +*> the M-by-N matrix A and M-by-NRHS matrix B, as in +*> +*> N NRHS +*> array_A = M [ mat_A, mat_B ] +*> +*> On exit: +*> 1. The elements in block A(IOFFSET+1:M,1:K) below +*> the diagonal together with the array TAU represent +*> the orthogonal matrix Q(K) as a product of elementary +*> reflectors. +*> 2. The upper triangular block of the matrix A stored +*> in A(IOFFSET+1:M,1:K) is the triangular factor obtained. +*> 3. The block of the matrix A stored in A(1:IOFFSET,1:N) +*> has been accordingly pivoted, but not factorized. +*> 4. The rest of the array A, block A(IOFFSET+1:M,K+1:N+NRHS). +*> The left part A(IOFFSET+1:M,K+1:N) of this block +*> contains the residual of the matrix A, and, +*> if NRHS > 0, the right part of the block +*> A(IOFFSET+1:M,N+1:N+NRHS) contains the block of +*> the right-hand-side matrix B. Both these blocks have been +*> updated by multiplication from the left by Q(K)**H. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] K +*> \verbatim +*> K is INTEGER +*> Factorization rank of the matrix A, i.e. the rank of +*> the factor R, which is the same as the number of non-zero +*> rows of the factor R. 0 <= K <= min(M-IOFFSET,KMAX,N). +*> +*> K also represents the number of non-zero Householder +*> vectors. +*> \endverbatim +*> +*> \param[out] MAXC2NRMK +*> \verbatim +*> MAXC2NRMK is REAL +*> The maximum column 2-norm of the residual matrix, +*> when the factorization stopped at rank K. MAXC2NRMK >= 0. +*> \endverbatim +*> +*> \param[out] RELMAXC2NRMK +*> \verbatim +*> RELMAXC2NRMK is REAL +*> The ratio MAXC2NRMK / MAXC2NRM of the maximum column +*> 2-norm of the residual matrix (when the factorization +*> stopped at rank K) to the maximum column 2-norm of the +*> whole original matrix A. RELMAXC2NRMK >= 0. +*> \endverbatim +*> +*> \param[out] JPIV +*> \verbatim +*> JPIV is INTEGER array, dimension (N) +*> Column pivot indices, for 1 <= j <= N, column j +*> of the matrix A was interchanged with column JPIV(j). +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is COMPLEX array, dimension (min(M-IOFFSET,N)) +*> The scalar factors of the elementary reflectors. +*> \endverbatim +*> +*> \param[in,out] VN1 +*> \verbatim +*> VN1 is REAL array, dimension (N) +*> The vector with the partial column norms. +*> \endverbatim +*> +*> \param[in,out] VN2 +*> \verbatim +*> VN2 is REAL array, dimension (N) +*> The vector with the exact column norms. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX array, dimension (N-1) +*> Used in CLARF subroutine to apply an elementary +*> reflector from the left. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> 1) INFO = 0: successful exit. +*> 2) If INFO = j_1, where 1 <= j_1 <= N, then NaN was +*> detected and the routine stops the computation. +*> The j_1-th column of the matrix A or the j_1-th +*> element of array TAU contains the first occurrence +*> of NaN in the factorization step K+1 ( when K columns +*> have been factorized ). +*> +*> On exit: +*> K is set to the number of +*> factorized columns without +*> exception. +*> MAXC2NRMK is set to NaN. +*> RELMAXC2NRMK is set to NaN. +*> TAU(K+1:min(M,N)) is not set and contains undefined +*> elements. If j_1=K+1, TAU(K+1) +*> may contain NaN. +*> 3) If INFO = j_2, where N+1 <= j_2 <= 2*N, then no NaN +*> was detected, but +Inf (or -Inf) was detected and +*> the routine continues the computation until completion. +*> The (j_2-N)-th column of the matrix A contains the first +*> occurrence of +Inf (or -Inf) in the factorization +*> step K+1 ( when K columns have been factorized ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup laqp2rk +* +*> \par References: +* ================ +*> [1] A Level 3 BLAS QR factorization algorithm with column pivoting developed in 1996. +*> G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain. +*> X. Sun, Computer Science Dept., Duke University, USA. +*> C. H. Bischof, Math. and Comp. Sci. Div., Argonne National Lab, USA. +*> A BLAS-3 version of the QR factorization with column pivoting. +*> LAPACK Working Note 114 +*> \htmlonly +*> https://www.netlib.org/lapack/lawnspdf/lawn114.pdf +*> \endhtmlonly +*> and in +*> SIAM J. Sci. Comput., 19(5):1486-1494, Sept. 1998. +*> \htmlonly +*> https://doi.org/10.1137/S1064827595296732 +*> \endhtmlonly +*> +*> [2] A partial column norm updating strategy developed in 2006. +*> Z. Drmac and Z. Bujanovic, Dept. of Math., University of Zagreb, Croatia. +*> On the failure of rank revealing QR factorization software – a case study. +*> LAPACK Working Note 176. +*> \htmlonly +*> http://www.netlib.org/lapack/lawnspdf/lawn176.pdf +*> \endhtmlonly +*> and in +*> ACM Trans. Math. Softw. 35, 2, Article 12 (July 2008), 28 pages. +*> \htmlonly +*> https://doi.org/10.1145/1377612.1377616 +*> \endhtmlonly +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> November 2023, Igor Kozachenko, James Demmel, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE CLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, + $ KP1, MAXC2NRM, A, LDA, K, MAXC2NRMK, + $ RELMAXC2NRMK, JPIV, TAU, VN1, VN2, WORK, + $ INFO ) + IMPLICIT NONE +* +* -- LAPACK auxiliary routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER INFO, IOFFSET, KP1, K, KMAX, LDA, M, N, NRHS + REAL ABSTOL, MAXC2NRM, MAXC2NRMK, RELMAXC2NRMK, + $ RELTOL +* .. +* .. Array Arguments .. + INTEGER JPIV( * ) + REAL VN1( * ), VN2( * ) + COMPLEX A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) + COMPLEX CZERO, CONE + PARAMETER ( CZERO = ( 0.0E+0, 0.0E+0 ), + $ CONE = ( 1.0E+0, 0.0E+0 ) ) +* .. +* .. Local Scalars .. + INTEGER I, ITEMP, J, JMAXC2NRM, KK, KP, MINMNFACT, + $ MINMNUPDT + REAL HUGEVAL, TAUNAN, TEMP, TEMP2, TOL3Z + COMPLEX AIKK +* .. +* .. External Subroutines .. + EXTERNAL CLARF, CLARFG, CSWAP +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, REAL, CONJG, IMAG, MAX, MIN, SQRT +* .. +* .. External Functions .. + LOGICAL SISNAN + INTEGER ISAMAX + REAL SLAMCH, SCNRM2 + EXTERNAL SISNAN, SLAMCH, ISAMAX, SCNRM2 +* .. +* .. Executable Statements .. +* +* Initialize INFO +* + INFO = 0 +* +* MINMNFACT in the smallest dimension of the submatrix +* A(IOFFSET+1:M,1:N) to be factorized. +* +* MINMNUPDT is the smallest dimension +* of the subarray A(IOFFSET+1:M,1:N+NRHS) to be udated, which +* contains the submatrices A(IOFFSET+1:M,1:N) and +* B(IOFFSET+1:M,1:NRHS) as column blocks. +* + MINMNFACT = MIN( M-IOFFSET, N ) + MINMNUPDT = MIN( M-IOFFSET, N+NRHS ) + KMAX = MIN( KMAX, MINMNFACT ) + TOL3Z = SQRT( SLAMCH( 'Epsilon' ) ) + HUGEVAL = SLAMCH( 'Overflow' ) +* +* Compute the factorization, KK is the lomn loop index. +* + DO KK = 1, KMAX +* + I = IOFFSET + KK +* + IF( I.EQ.1 ) THEN +* +* ============================================================ +* +* We are at the first column of the original whole matrix A, +* therefore we use the computed KP1 and MAXC2NRM from the +* main routine. +* + KP = KP1 +* +* ============================================================ +* + ELSE +* +* ============================================================ +* +* Determine the pivot column in KK-th step, i.e. the index +* of the column with the maximum 2-norm in the +* submatrix A(I:M,K:N). +* + KP = ( KK-1 ) + ISAMAX( N-KK+1, VN1( KK ), 1 ) +* +* Determine the maximum column 2-norm and the relative maximum +* column 2-norm of the submatrix A(I:M,KK:N) in step KK. +* RELMAXC2NRMK will be computed later, after somecondition +* checks on MAXC2NRMK. +* + MAXC2NRMK = VN1( KP ) +* +* ============================================================ +* +* Check if the submatrix A(I:M,KK:N) contains NaN, and set +* INFO parameter to the column number, where the first NaN +* is found and return from the routine. +* We need to check the condition only if the +* column index (same as row index) of the original whole +* matrix is larger than 1, since the condition for whole +* original matrix is checked in the main routine. +* + IF( SISNAN( MAXC2NRMK ) ) THEN +* +* Set K, the number of factorized columns. +* that are not zero. +* + K = KK - 1 + INFO = K + KP +* +* Set RELMAXC2NRMK to NaN. +* + RELMAXC2NRMK = MAXC2NRMK +* +* Array TAU(K+1:MINMNFACT) is not set and contains +* undefined elements. +* + RETURN + END IF +* +* ============================================================ +* +* Quick return, if the submatrix A(I:M,KK:N) is +* a zero matrix. +* We need to check the condition only if the +* column index (same as row index) of the original whole +* matrix is larger than 1, since the condition for whole +* original matrix is checked in the main routine. +* + IF( MAXC2NRMK.EQ.ZERO ) THEN +* +* Set K, the number of factorized columns. +* that are not zero. +* + K = KK - 1 + RELMAXC2NRMK = ZERO +* +* Set TAUs corresponding to the columns that were not +* factorized to ZERO, i.e. set TAU(KK:MINMNFACT) to CZERO. +* + DO J = KK, MINMNFACT + TAU( J ) = CZERO + END DO +* +* Return from the routine. +* + RETURN +* + END IF +* +* ============================================================ +* +* Check if the submatrix A(I:M,KK:N) contains Inf, +* set INFO parameter to the column number, where +* the first Inf is found plus N, and continue +* the computation. +* We need to check the condition only if the +* column index (same as row index) of the original whole +* matrix is larger than 1, since the condition for whole +* original matrix is checked in the main routine. +* + IF( INFO.EQ.0 .AND. MAXC2NRMK.GT.HUGEVAL ) THEN + INFO = N + KK - 1 + KP + END IF +* +* ============================================================ +* +* Test for the second and third stopping criteria. +* NOTE: There is no need to test for ABSTOL >= ZERO, since +* MAXC2NRMK is non-negative. Similarly, there is no need +* to test for RELTOL >= ZERO, since RELMAXC2NRMK is +* non-negative. +* We need to check the condition only if the +* column index (same as row index) of the original whole +* matrix is larger than 1, since the condition for whole +* original matrix is checked in the main routine. + + RELMAXC2NRMK = MAXC2NRMK / MAXC2NRM +* + IF( MAXC2NRMK.LE.ABSTOL .OR. RELMAXC2NRMK.LE.RELTOL ) THEN +* +* Set K, the number of factorized columns. +* + K = KK - 1 +* +* Set TAUs corresponding to the columns that were not +* factorized to ZERO, i.e. set TAU(KK:MINMNFACT) to CZERO. +* + DO J = KK, MINMNFACT + TAU( J ) = CZERO + END DO +* +* Return from the routine. +* + RETURN +* + END IF +* +* ============================================================ +* +* End ELSE of IF(I.EQ.1) +* + END IF +* +* =============================================================== +* +* If the pivot column is not the first column of the +* subblock A(1:M,KK:N): +* 1) swap the KK-th column and the KP-th pivot column +* in A(1:M,1:N); +* 2) copy the KK-th element into the KP-th element of the partial +* and exact 2-norm vectors VN1 and VN2. ( Swap is not needed +* for VN1 and VN2 since we use the element with the index +* larger than KK in the next loop step.) +* 3) Save the pivot interchange with the indices relative to the +* the original matrix A, not the block A(1:M,1:N). +* + IF( KP.NE.KK ) THEN + CALL CSWAP( M, A( 1, KP ), 1, A( 1, KK ), 1 ) + VN1( KP ) = VN1( KK ) + VN2( KP ) = VN2( KK ) + ITEMP = JPIV( KP ) + JPIV( KP ) = JPIV( KK ) + JPIV( KK ) = ITEMP + END IF +* +* Generate elementary reflector H(KK) using the column A(I:M,KK), +* if the column has more than one element, otherwise +* the elementary reflector would be an identity matrix, +* and TAU(KK) = CZERO. +* + IF( I.LT.M ) THEN + CALL CLARFG( M-I+1, A( I, KK ), A( I+1, KK ), 1, + $ TAU( KK ) ) + ELSE + TAU( KK ) = CZERO + END IF +* +* Check if TAU(KK) contains NaN, set INFO parameter +* to the column number where NaN is found and return from +* the routine. +* NOTE: There is no need to check TAU(KK) for Inf, +* since CLARFG cannot produce TAU(KK) or Householder vector +* below the diagonal containing Inf. Only BETA on the diagonal, +* returned by CLARFG can contain Inf, which requires +* TAU(KK) to contain NaN. Therefore, this case of generating Inf +* by CLARFG is covered by checking TAU(KK) for NaN. +* + IF( SISNAN( REAL( TAU(KK) ) ) ) THEN + TAUNAN = REAL( TAU(KK) ) + ELSE IF( SISNAN( IMAG( TAU(KK) ) ) ) THEN + TAUNAN = IMAG( TAU(KK) ) + ELSE + TAUNAN = ZERO + END IF +* + IF( SISNAN( TAUNAN ) ) THEN + K = KK - 1 + INFO = KK +* +* Set MAXC2NRMK and RELMAXC2NRMK to NaN. +* + MAXC2NRMK = TAUNAN + RELMAXC2NRMK = TAUNAN +* +* Array TAU(KK:MINMNFACT) is not set and contains +* undefined elements, except the first element TAU(KK) = NaN. +* + RETURN + END IF +* +* Apply H(KK)**H to A(I:M,KK+1:N+NRHS) from the left. +* ( If M >= N, then at KK = N there is no residual matrix, +* i.e. no columns of A to update, only columns of B. +* If M < N, then at KK = M-IOFFSET, I = M and we have a +* one-row residual matrix in A and the elementary +* reflector is a unit matrix, TAU(KK) = CZERO, i.e. no update +* is needed for the residual matrix in A and the +* right-hand-side-matrix in B. +* Therefore, we update only if +* KK < MINMNUPDT = min(M-IOFFSET, N+NRHS) +* condition is satisfied, not only KK < N+NRHS ) +* + IF( KK.LT.MINMNUPDT ) THEN + AIKK = A( I, KK ) + A( I, KK ) = CONE + CALL CLARF( 'Left', M-I+1, N+NRHS-KK, A( I, KK ), 1, + $ CONJG( TAU( KK ) ), A( I, KK+1 ), LDA, + $ WORK( 1 ) ) + A( I, KK ) = AIKK + END IF +* + IF( KK.LT.MINMNFACT ) THEN +* +* Update the partial column 2-norms for the residual matrix, +* only if the residual matrix A(I+1:M,KK+1:N) exists, i.e. +* when KK < min(M-IOFFSET, N). +* + DO J = KK + 1, N + IF( VN1( J ).NE.ZERO ) THEN +* +* NOTE: The following lines follow from the analysis in +* Lapack Working Note 176. +* + TEMP = ONE - ( ABS( A( I, J ) ) / VN1( J ) )**2 + TEMP = MAX( TEMP, ZERO ) + TEMP2 = TEMP*( VN1( J ) / VN2( J ) )**2 + IF( TEMP2 .LE. TOL3Z ) THEN +* +* Compute the column 2-norm for the partial +* column A(I+1:M,J) by explicitly computing it, +* and store it in both partial 2-norm vector VN1 +* and exact column 2-norm vector VN2. +* + VN1( J ) = SCNRM2( M-I, A( I+1, J ), 1 ) + VN2( J ) = VN1( J ) +* + ELSE +* +* Update the column 2-norm for the partial +* column A(I+1:M,J) by removing one +* element A(I,J) and store it in partial +* 2-norm vector VN1. +* + VN1( J ) = VN1( J )*SQRT( TEMP ) +* + END IF + END IF + END DO +* + END IF +* +* End factorization loop +* + END DO +* +* If we reached this point, all colunms have been factorized, +* i.e. no condition was triggered to exit the routine. +* Set the number of factorized columns. +* + K = KMAX +* +* We reached the end of the loop, i.e. all KMAX columns were +* factorized, we need to set MAXC2NRMK and RELMAXC2NRMK before +* we return. +* + IF( K.LT.MINMNFACT ) THEN +* + JMAXC2NRM = K + ISAMAX( N-K, VN1( K+1 ), 1 ) + MAXC2NRMK = VN1( JMAXC2NRM ) +* + IF( K.EQ.0 ) THEN + RELMAXC2NRMK = ONE + ELSE + RELMAXC2NRMK = MAXC2NRMK / MAXC2NRM + END IF +* + ELSE + MAXC2NRMK = ZERO + RELMAXC2NRMK = ZERO + END IF +* +* We reached the end of the loop, i.e. all KMAX columns were +* factorized, set TAUs corresponding to the columns that were +* not factorized to ZERO, i.e. TAU(K+1:MINMNFACT) set to CZERO. +* + DO J = K + 1, MINMNFACT + TAU( J ) = CZERO + END DO +* + RETURN +* +* End of CLAQP2RK +* + END diff --git a/lapack-netlib/SRC/claqp3rk.f b/lapack-netlib/SRC/claqp3rk.f new file mode 100644 index 000000000..af5e85645 --- /dev/null +++ b/lapack-netlib/SRC/claqp3rk.f @@ -0,0 +1,947 @@ +*> \brief \b CLAQP3RK computes a step of truncated QR factorization with column pivoting of a complex m-by-n matrix A using Level 3 BLAS and overwrites a complex m-by-nrhs matrix B with Q**H * B. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download CLAQP3RK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE CLAQP3RK( M, N, NRHS, IOFFSET, NB, ABSTOL, +* $ RELTOL, KP1, MAXC2NRM, A, LDA, DONE, KB, +* $ MAXC2NRMK, RELMAXC2NRMK, JPIV, TAU, +* $ VN1, VN2, AUXV, F, LDF, IWORK, INFO ) +* IMPLICIT NONE +* LOGICAL DONE +* INTEGER INFO, IOFFSET, KB, KP1, LDA, LDF, M, N, +* $ NB, NRHS +* REAL ABSTOL, MAXC2NRM, MAXC2NRMK, RELMAXC2NRMK, +* $ RELTOL +* .. +* .. Array Arguments .. +* INTEGER IWORK( * ), JPIV( * ) +* REAL VN1( * ), VN2( * ) +* COMPLEX*16 A( LDA, * ), AUXV( * ), F( LDF, * ), TAU( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CLAQP3RK computes a step of truncated QR factorization with column +*> pivoting of a complex M-by-N matrix A block A(IOFFSET+1:M,1:N) +*> by using Level 3 BLAS as +*> +*> A * P(KB) = Q(KB) * R(KB). +*> +*> The routine tries to factorize NB columns from A starting from +*> the row IOFFSET+1 and updates the residual matrix with BLAS 3 +*> xGEMM. The number of actually factorized columns is returned +*> is smaller than NB. +*> +*> Block A(1:IOFFSET,1:N) is accordingly pivoted, but not factorized. +*> +*> The routine also overwrites the right-hand-sides B matrix stored +*> in A(IOFFSET+1:M,1:N+1:N+NRHS) with Q(KB)**H * B. +*> +*> Cases when the number of factorized columns KB < NB: +*> +*> (1) In some cases, due to catastrophic cancellations, it cannot +*> factorize all NB columns and need to update the residual matrix. +*> Hence, the actual number of factorized columns in the block returned +*> in KB is smaller than NB. The logical DONE is returned as FALSE. +*> The factorization of the whole original matrix A_orig must proceed +*> with the next block. +*> +*> (2) Whenever the stopping criterion ABSTOL or RELTOL is satisfied, +*> the factorization of the whole original matrix A_orig is stopped, +*> the logical DONE is returned as TRUE. The number of factorized +*> columns which is smaller than NB is returned in KB. +*> +*> (3) In case both stopping criteria ABSTOL or RELTOL are not used, +*> and when the residual matrix is a zero matrix in some factorization +*> step KB, the factorization of the whole original matrix A_orig is +*> stopped, the logical DONE is returned as TRUE. The number of +*> factorized columns which is smaller than NB is returned in KB. +*> +*> (4) Whenever NaN is detected in the matrix A or in the array TAU, +*> the factorization of the whole original matrix A_orig is stopped, +*> the logical DONE is returned as TRUE. The number of factorized +*> columns which is smaller than NB is returned in KB. The INFO +*> parameter is set to the column index of the first NaN occurrence. +*> +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0 +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of +*> columns of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in] IOFFSET +*> \verbatim +*> IOFFSET is INTEGER +*> The number of rows of the matrix A that must be pivoted +*> but not factorized. IOFFSET >= 0. +*> +*> IOFFSET also represents the number of columns of the whole +*> original matrix A_orig that have been factorized +*> in the previous steps. +*> \endverbatim +*> +*> \param[in] NB +*> \verbatim +*> NB is INTEGER +*> Factorization block size, i.e the number of columns +*> to factorize in the matrix A. 0 <= NB +*> +*> If NB = 0, then the routine exits immediately. +*> This means that the factorization is not performed, +*> the matrices A and B and the arrays TAU, IPIV +*> are not modified. +*> \endverbatim +*> +*> \param[in] ABSTOL +*> \verbatim +*> ABSTOL is REAL, cannot be NaN. +*> +*> The absolute tolerance (stopping threshold) for +*> maximum column 2-norm of the residual matrix. +*> The algorithm converges (stops the factorization) when +*> the maximum column 2-norm of the residual matrix +*> is less than or equal to ABSTOL. +*> +*> a) If ABSTOL < 0.0, then this stopping criterion is not +*> used, the routine factorizes columns depending +*> on NB and RELTOL. +*> This includes the case ABSTOL = -Inf. +*> +*> b) If 0.0 <= ABSTOL then the input value +*> of ABSTOL is used. +*> \endverbatim +*> +*> \param[in] RELTOL +*> \verbatim +*> RELTOL is REAL, cannot be NaN. +*> +*> The tolerance (stopping threshold) for the ratio of the +*> maximum column 2-norm of the residual matrix to the maximum +*> column 2-norm of the original matrix A_orig. The algorithm +*> converges (stops the factorization), when this ratio is +*> less than or equal to RELTOL. +*> +*> a) If RELTOL < 0.0, then this stopping criterion is not +*> used, the routine factorizes columns depending +*> on NB and ABSTOL. +*> This includes the case RELTOL = -Inf. +*> +*> d) If 0.0 <= RELTOL then the input value of RELTOL +*> is used. +*> \endverbatim +*> +*> \param[in] KP1 +*> \verbatim +*> KP1 is INTEGER +*> The index of the column with the maximum 2-norm in +*> the whole original matrix A_orig determined in the +*> main routine CGEQP3RK. 1 <= KP1 <= N_orig. +*> \endverbatim +*> +*> \param[in] MAXC2NRM +*> \verbatim +*> MAXC2NRM is REAL +*> The maximum column 2-norm of the whole original +*> matrix A_orig computed in the main routine CGEQP3RK. +*> MAXC2NRM >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX array, dimension (LDA,N+NRHS) +*> On entry: +*> the M-by-N matrix A and M-by-NRHS matrix B, as in +*> +*> N NRHS +*> array_A = M [ mat_A, mat_B ] +*> +*> On exit: +*> 1. The elements in block A(IOFFSET+1:M,1:KB) below +*> the diagonal together with the array TAU represent +*> the orthogonal matrix Q(KB) as a product of elementary +*> reflectors. +*> 2. The upper triangular block of the matrix A stored +*> in A(IOFFSET+1:M,1:KB) is the triangular factor obtained. +*> 3. The block of the matrix A stored in A(1:IOFFSET,1:N) +*> has been accordingly pivoted, but not factorized. +*> 4. The rest of the array A, block A(IOFFSET+1:M,KB+1:N+NRHS). +*> The left part A(IOFFSET+1:M,KB+1:N) of this block +*> contains the residual of the matrix A, and, +*> if NRHS > 0, the right part of the block +*> A(IOFFSET+1:M,N+1:N+NRHS) contains the block of +*> the right-hand-side matrix B. Both these blocks have been +*> updated by multiplication from the left by Q(KB)**H. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] +*> \verbatim +*> DONE is LOGICAL +*> TRUE: a) if the factorization completed before processing +*> all min(M-IOFFSET,NB,N) columns due to ABSTOL +*> or RELTOL criterion, +*> b) if the factorization completed before processing +*> all min(M-IOFFSET,NB,N) columns due to the +*> residual matrix being a ZERO matrix. +*> c) when NaN was detected in the matrix A +*> or in the array TAU. +*> FALSE: otherwise. +*> \endverbatim +*> +*> \param[out] KB +*> \verbatim +*> KB is INTEGER +*> Factorization rank of the matrix A, i.e. the rank of +*> the factor R, which is the same as the number of non-zero +*> rows of the factor R. 0 <= KB <= min(M-IOFFSET,NB,N). +*> +*> KB also represents the number of non-zero Householder +*> vectors. +*> \endverbatim +*> +*> \param[out] MAXC2NRMK +*> \verbatim +*> MAXC2NRMK is REAL +*> The maximum column 2-norm of the residual matrix, +*> when the factorization stopped at rank KB. MAXC2NRMK >= 0. +*> \endverbatim +*> +*> \param[out] RELMAXC2NRMK +*> \verbatim +*> RELMAXC2NRMK is REAL +*> The ratio MAXC2NRMK / MAXC2NRM of the maximum column +*> 2-norm of the residual matrix (when the factorization +*> stopped at rank KB) to the maximum column 2-norm of the +*> original matrix A_orig. RELMAXC2NRMK >= 0. +*> \endverbatim +*> +*> \param[out] JPIV +*> \verbatim +*> JPIV is INTEGER array, dimension (N) +*> Column pivot indices, for 1 <= j <= N, column j +*> of the matrix A was interchanged with column JPIV(j). +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is COMPLEX array, dimension (min(M-IOFFSET,N)) +*> The scalar factors of the elementary reflectors. +*> \endverbatim +*> +*> \param[in,out] VN1 +*> \verbatim +*> VN1 is REAL array, dimension (N) +*> The vector with the partial column norms. +*> \endverbatim +*> +*> \param[in,out] VN2 +*> \verbatim +*> VN2 is REAL array, dimension (N) +*> The vector with the exact column norms. +*> \endverbatim +*> +*> \param[out] AUXV +*> \verbatim +*> AUXV is COMPLEX array, dimension (NB) +*> Auxiliary vector. +*> \endverbatim +*> +*> \param[out] F +*> \verbatim +*> F is COMPLEX array, dimension (LDF,NB) +*> Matrix F**H = L*(Y**H)*A. +*> \endverbatim +*> +*> \param[in] LDF +*> \verbatim +*> LDF is INTEGER +*> The leading dimension of the array F. LDF >= max(1,N+NRHS). +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (N-1). +*> Is a work array. ( IWORK is used to store indices +*> of "bad" columns for norm downdating in the residual +*> matrix ). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> 1) INFO = 0: successful exit. +*> 2) If INFO = j_1, where 1 <= j_1 <= N, then NaN was +*> detected and the routine stops the computation. +*> The j_1-th column of the matrix A or the j_1-th +*> element of array TAU contains the first occurrence +*> of NaN in the factorization step KB+1 ( when KB columns +*> have been factorized ). +*> +*> On exit: +*> KB is set to the number of +*> factorized columns without +*> exception. +*> MAXC2NRMK is set to NaN. +*> RELMAXC2NRMK is set to NaN. +*> TAU(KB+1:min(M,N)) is not set and contains undefined +*> elements. If j_1=KB+1, TAU(KB+1) +*> may contain NaN. +*> 3) If INFO = j_2, where N+1 <= j_2 <= 2*N, then no NaN +*> was detected, but +Inf (or -Inf) was detected and +*> the routine continues the computation until completion. +*> The (j_2-N)-th column of the matrix A contains the first +*> occurrence of +Inf (or -Inf) in the actorization +*> step KB+1 ( when KB columns have been factorized ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup laqp3rk +* +*> \par References: +* ================ +*> [1] A Level 3 BLAS QR factorization algorithm with column pivoting developed in 1996. +*> G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain. +*> X. Sun, Computer Science Dept., Duke University, USA. +*> C. H. Bischof, Math. and Comp. Sci. Div., Argonne National Lab, USA. +*> A BLAS-3 version of the QR factorization with column pivoting. +*> LAPACK Working Note 114 +*> \htmlonly +*> https://www.netlib.org/lapack/lawnspdf/lawn114.pdf +*> \endhtmlonly +*> and in +*> SIAM J. Sci. Comput., 19(5):1486-1494, Sept. 1998. +*> \htmlonly +*> https://doi.org/10.1137/S1064827595296732 +*> \endhtmlonly +*> +*> [2] A partial column norm updating strategy developed in 2006. +*> Z. Drmac and Z. Bujanovic, Dept. of Math., University of Zagreb, Croatia. +*> On the failure of rank revealing QR factorization software – a case study. +*> LAPACK Working Note 176. +*> \htmlonly +*> http://www.netlib.org/lapack/lawnspdf/lawn176.pdf +*> \endhtmlonly +*> and in +*> ACM Trans. Math. Softw. 35, 2, Article 12 (July 2008), 28 pages. +*> \htmlonly +*> https://doi.org/10.1145/1377612.1377616 +*> \endhtmlonly +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> November 2023, Igor Kozachenko, James Demmel, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE CLAQP3RK( M, N, NRHS, IOFFSET, NB, ABSTOL, + $ RELTOL, KP1, MAXC2NRM, A, LDA, DONE, KB, + $ MAXC2NRMK, RELMAXC2NRMK, JPIV, TAU, + $ VN1, VN2, AUXV, F, LDF, IWORK, INFO ) + IMPLICIT NONE +* +* -- LAPACK auxiliary routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + LOGICAL DONE + INTEGER INFO, IOFFSET, KB, KP1, LDA, LDF, M, N, + $ NB, NRHS + REAL ABSTOL, MAXC2NRM, MAXC2NRMK, RELMAXC2NRMK, + $ RELTOL +* .. +* .. Array Arguments .. + INTEGER IWORK( * ), JPIV( * ) + REAL VN1( * ), VN2( * ) + COMPLEX A( LDA, * ), AUXV( * ), F( LDF, * ), TAU( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) + COMPLEX CZERO, CONE + PARAMETER ( CZERO = ( 0.0E+0, 0.0E+0 ), + $ CONE = ( 1.0E+0, 0.0E+0 ) ) +* .. +* .. Local Scalars .. + INTEGER ITEMP, J, K, MINMNFACT, MINMNUPDT, + $ LSTICC, KP, I, IF + REAL HUGEVAL, TAUNAN, TEMP, TEMP2, TOL3Z + COMPLEX AIK +* .. +* .. External Subroutines .. + EXTERNAL CGEMM, CGEMV, CLARFG, CSWAP +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, REAL, CONJG, IMAG, MAX, MIN, SQRT +* .. +* .. External Functions .. + LOGICAL SISNAN + INTEGER ISAMAX + REAL SLAMCH, SCNRM2 + EXTERNAL SISNAN, SLAMCH, ISAMAX, SCNRM2 +* .. +* .. Executable Statements .. +* +* Initialize INFO +* + INFO = 0 +* +* MINMNFACT in the smallest dimension of the submatrix +* A(IOFFSET+1:M,1:N) to be factorized. +* + MINMNFACT = MIN( M-IOFFSET, N ) + MINMNUPDT = MIN( M-IOFFSET, N+NRHS ) + NB = MIN( NB, MINMNFACT ) + TOL3Z = SQRT( SLAMCH( 'Epsilon' ) ) + HUGEVAL = SLAMCH( 'Overflow' ) +* +* Compute factorization in a while loop over NB columns, +* K is the column index in the block A(1:M,1:N). +* + K = 0 + LSTICC = 0 + DONE = .FALSE. +* + DO WHILE ( K.LT.NB .AND. LSTICC.EQ.0 ) + K = K + 1 + I = IOFFSET + K +* + IF( I.EQ.1 ) THEN +* +* We are at the first column of the original whole matrix A_orig, +* therefore we use the computed KP1 and MAXC2NRM from the +* main routine. +* + KP = KP1 +* + ELSE +* +* Determine the pivot column in K-th step, i.e. the index +* of the column with the maximum 2-norm in the +* submatrix A(I:M,K:N). +* + KP = ( K-1 ) + ISAMAX( N-K+1, VN1( K ), 1 ) +* +* Determine the maximum column 2-norm and the relative maximum +* column 2-norm of the submatrix A(I:M,K:N) in step K. +* + MAXC2NRMK = VN1( KP ) +* +* ============================================================ +* +* Check if the submatrix A(I:M,K:N) contains NaN, set +* INFO parameter to the column number, where the first NaN +* is found and return from the routine. +* We need to check the condition only if the +* column index (same as row index) of the original whole +* matrix is larger than 1, since the condition for whole +* original matrix is checked in the main routine. +* + IF( SISNAN( MAXC2NRMK ) ) THEN +* + DONE = .TRUE. +* +* Set KB, the number of factorized partial columns +* that are non-zero in each step in the block, +* i.e. the rank of the factor R. +* Set IF, the number of processed rows in the block, which +* is the same as the number of processed rows in +* the original whole matrix A_orig. +* + KB = K - 1 + IF = I - 1 + INFO = KB + KP +* +* Set RELMAXC2NRMK to NaN. +* + RELMAXC2NRMK = MAXC2NRMK +* +* There is no need to apply the block reflector to the +* residual of the matrix A stored in A(KB+1:M,KB+1:N), +* since the submatrix contains NaN and we stop +* the computation. +* But, we need to apply the block reflector to the residual +* right hand sides stored in A(KB+1:M,N+1:N+NRHS), if the +* residual right hand sides exist. This occurs +* when ( NRHS != 0 AND KB <= (M-IOFFSET) ): +* +* A(I+1:M,N+1:N+NRHS) := A(I+1:M,N+1:N+NRHS) - +* A(I+1:M,1:KB) * F(N+1:N+NRHS,1:KB)**H. + + IF( NRHS.GT.0 .AND. KB.LT.(M-IOFFSET) ) THEN + CALL CGEMM( 'No transpose', 'Conjugate transpose', + $ M-IF, NRHS, KB, -CONE, A( IF+1, 1 ), LDA, + $ F( N+1, 1 ), LDF, CONE, A( IF+1, N+1 ), LDA ) + END IF +* +* There is no need to recompute the 2-norm of the +* difficult columns, since we stop the factorization. +* +* Array TAU(KF+1:MINMNFACT) is not set and contains +* undefined elements. +* +* Return from the routine. +* + RETURN + END IF +* +* Quick return, if the submatrix A(I:M,K:N) is +* a zero matrix. We need to check it only if the column index +* (same as row index) is larger than 1, since the condition +* for the whole original matrix A_orig is checked in the main +* routine. +* + IF( MAXC2NRMK.EQ.ZERO ) THEN +* + DONE = .TRUE. +* +* Set KB, the number of factorized partial columns +* that are non-zero in each step in the block, +* i.e. the rank of the factor R. +* Set IF, the number of processed rows in the block, which +* is the same as the number of processed rows in +* the original whole matrix A_orig. +* + KB = K - 1 + IF = I - 1 + RELMAXC2NRMK = ZERO +* +* There is no need to apply the block reflector to the +* residual of the matrix A stored in A(KB+1:M,KB+1:N), +* since the submatrix is zero and we stop the computation. +* But, we need to apply the block reflector to the residual +* right hand sides stored in A(KB+1:M,N+1:N+NRHS), if the +* residual right hand sides exist. This occurs +* when ( NRHS != 0 AND KB <= (M-IOFFSET) ): +* +* A(I+1:M,N+1:N+NRHS) := A(I+1:M,N+1:N+NRHS) - +* A(I+1:M,1:KB) * F(N+1:N+NRHS,1:KB)**H. +* + IF( NRHS.GT.0 .AND. KB.LT.(M-IOFFSET) ) THEN + CALL CGEMM( 'No transpose', 'Conjugate transpose', + $ M-IF, NRHS, KB, -CONE, A( IF+1, 1 ), LDA, + $ F( N+1, 1 ), LDF, CONE, A( IF+1, N+1 ), LDA ) + END IF +* +* There is no need to recompute the 2-norm of the +* difficult columns, since we stop the factorization. +* +* Set TAUs corresponding to the columns that were not +* factorized to ZERO, i.e. set TAU(KB+1:MINMNFACT) = CZERO, +* which is equivalent to seting TAU(K:MINMNFACT) = CZERO. +* + DO J = K, MINMNFACT + TAU( J ) = CZERO + END DO +* +* Return from the routine. +* + RETURN +* + END IF +* +* ============================================================ +* +* Check if the submatrix A(I:M,K:N) contains Inf, +* set INFO parameter to the column number, where +* the first Inf is found plus N, and continue +* the computation. +* We need to check the condition only if the +* column index (same as row index) of the original whole +* matrix is larger than 1, since the condition for whole +* original matrix is checked in the main routine. +* + IF( INFO.EQ.0 .AND. MAXC2NRMK.GT.HUGEVAL ) THEN + INFO = N + K - 1 + KP + END IF +* +* ============================================================ +* +* Test for the second and third tolerance stopping criteria. +* NOTE: There is no need to test for ABSTOL.GE.ZERO, since +* MAXC2NRMK is non-negative. Similarly, there is no need +* to test for RELTOL.GE.ZERO, since RELMAXC2NRMK is +* non-negative. +* We need to check the condition only if the +* column index (same as row index) of the original whole +* matrix is larger than 1, since the condition for whole +* original matrix is checked in the main routine. +* + RELMAXC2NRMK = MAXC2NRMK / MAXC2NRM +* + IF( MAXC2NRMK.LE.ABSTOL .OR. RELMAXC2NRMK.LE.RELTOL ) THEN +* + DONE = .TRUE. +* +* Set KB, the number of factorized partial columns +* that are non-zero in each step in the block, +* i.e. the rank of the factor R. +* Set IF, the number of processed rows in the block, which +* is the same as the number of processed rows in +* the original whole matrix A_orig; +* + KB = K - 1 + IF = I - 1 +* +* Apply the block reflector to the residual of the +* matrix A and the residual of the right hand sides B, if +* the residual matrix and and/or the residual of the right +* hand sides exist, i.e. if the submatrix +* A(I+1:M,KB+1:N+NRHS) exists. This occurs when +* KB < MINMNUPDT = min( M-IOFFSET, N+NRHS ): +* +* A(IF+1:M,K+1:N+NRHS) := A(IF+1:M,KB+1:N+NRHS) - +* A(IF+1:M,1:KB) * F(KB+1:N+NRHS,1:KB)**H. +* + IF( KB.LT.MINMNUPDT ) THEN + CALL CGEMM( 'No transpose', 'Conjugate transpose', + $ M-IF, N+NRHS-KB, KB,-CONE, A( IF+1, 1 ), LDA, + $ F( KB+1, 1 ), LDF, CONE, A( IF+1, KB+1 ), LDA ) + END IF +* +* There is no need to recompute the 2-norm of the +* difficult columns, since we stop the factorization. +* +* Set TAUs corresponding to the columns that were not +* factorized to ZERO, i.e. set TAU(KB+1:MINMNFACT) = CZERO, +* which is equivalent to seting TAU(K:MINMNFACT) = CZERO. +* + DO J = K, MINMNFACT + TAU( J ) = CZERO + END DO +* +* Return from the routine. +* + RETURN +* + END IF +* +* ============================================================ +* +* End ELSE of IF(I.EQ.1) +* + END IF +* +* =============================================================== +* +* If the pivot column is not the first column of the +* subblock A(1:M,K:N): +* 1) swap the K-th column and the KP-th pivot column +* in A(1:M,1:N); +* 2) swap the K-th row and the KP-th row in F(1:N,1:K-1) +* 3) copy the K-th element into the KP-th element of the partial +* and exact 2-norm vectors VN1 and VN2. (Swap is not needed +* for VN1 and VN2 since we use the element with the index +* larger than K in the next loop step.) +* 4) Save the pivot interchange with the indices relative to the +* the original matrix A_orig, not the block A(1:M,1:N). +* + IF( KP.NE.K ) THEN + CALL CSWAP( M, A( 1, KP ), 1, A( 1, K ), 1 ) + CALL CSWAP( K-1, F( KP, 1 ), LDF, F( K, 1 ), LDF ) + VN1( KP ) = VN1( K ) + VN2( KP ) = VN2( K ) + ITEMP = JPIV( KP ) + JPIV( KP ) = JPIV( K ) + JPIV( K ) = ITEMP + END IF +* +* Apply previous Householder reflectors to column K: +* A(I:M,K) := A(I:M,K) - A(I:M,1:K-1)*F(K,1:K-1)**H. +* + IF( K.GT.1 ) THEN + DO J = 1, K - 1 + F( K, J ) = CONJG( F( K, J ) ) + END DO + CALL CGEMV( 'No transpose', M-I+1, K-1, -CONE, A( I, 1 ), + $ LDA, F( K, 1 ), LDF, CONE, A( I, K ), 1 ) + DO J = 1, K - 1 + F( K, J ) = CONJG( F( K, J ) ) + END DO + END IF +* +* Generate elementary reflector H(k) using the column A(I:M,K). +* + IF( I.LT.M ) THEN + CALL CLARFG( M-I+1, A( I, K ), A( I+1, K ), 1, TAU( K ) ) + ELSE + TAU( K ) = CZERO + END IF +* +* Check if TAU(K) contains NaN, set INFO parameter +* to the column number where NaN is found and return from +* the routine. +* NOTE: There is no need to check TAU(K) for Inf, +* since CLARFG cannot produce TAU(KK) or Householder vector +* below the diagonal containing Inf. Only BETA on the diagonal, +* returned by CLARFG can contain Inf, which requires +* TAU(K) to contain NaN. Therefore, this case of generating Inf +* by CLARFG is covered by checking TAU(K) for NaN. +* + IF( SISNAN( REAL( TAU(K) ) ) ) THEN + TAUNAN = REAL( TAU(K) ) + ELSE IF( SISNAN( IMAG( TAU(K) ) ) ) THEN + TAUNAN = IMAG( TAU(K) ) + ELSE + TAUNAN = ZERO + END IF +* + IF( SISNAN( TAUNAN ) ) THEN +* + DONE = .TRUE. +* +* Set KB, the number of factorized partial columns +* that are non-zero in each step in the block, +* i.e. the rank of the factor R. +* Set IF, the number of processed rows in the block, which +* is the same as the number of processed rows in +* the original whole matrix A_orig. +* + KB = K - 1 + IF = I - 1 + INFO = K +* +* Set MAXC2NRMK and RELMAXC2NRMK to NaN. +* + MAXC2NRMK = TAUNAN + RELMAXC2NRMK = TAUNAN +* +* There is no need to apply the block reflector to the +* residual of the matrix A stored in A(KB+1:M,KB+1:N), +* since the submatrix contains NaN and we stop +* the computation. +* But, we need to apply the block reflector to the residual +* right hand sides stored in A(KB+1:M,N+1:N+NRHS), if the +* residual right hand sides exist. This occurs +* when ( NRHS != 0 AND KB <= (M-IOFFSET) ): +* +* A(I+1:M,N+1:N+NRHS) := A(I+1:M,N+1:N+NRHS) - +* A(I+1:M,1:KB) * F(N+1:N+NRHS,1:KB)**H. +* + IF( NRHS.GT.0 .AND. KB.LT.(M-IOFFSET) ) THEN + CALL CGEMM( 'No transpose', 'Conjugate transpose', + $ M-IF, NRHS, KB, -CONE, A( IF+1, 1 ), LDA, + $ F( N+1, 1 ), LDF, CONE, A( IF+1, N+1 ), LDA ) + END IF +* +* There is no need to recompute the 2-norm of the +* difficult columns, since we stop the factorization. +* +* Array TAU(KF+1:MINMNFACT) is not set and contains +* undefined elements. +* +* Return from the routine. +* + RETURN + END IF +* +* =============================================================== +* + AIK = A( I, K ) + A( I, K ) = CONE +* +* =============================================================== +* +* Compute the current K-th column of F: +* 1) F(K+1:N,K) := tau(K) * A(I:M,K+1:N)**H * A(I:M,K). +* + IF( K.LT.N+NRHS ) THEN + CALL CGEMV( 'Conjugate transpose', M-I+1, N+NRHS-K, + $ TAU( K ), A( I, K+1 ), LDA, A( I, K ), 1, + $ CZERO, F( K+1, K ), 1 ) + END IF +* +* 2) Zero out elements above and on the diagonal of the +* column K in matrix F, i.e elements F(1:K,K). +* + DO J = 1, K + F( J, K ) = CZERO + END DO +* +* 3) Incremental updating of the K-th column of F: +* F(1:N,K) := F(1:N,K) - tau(K) * F(1:N,1:K-1) * A(I:M,1:K-1)**H +* * A(I:M,K). +* + IF( K.GT.1 ) THEN + CALL CGEMV( 'Conjugate Transpose', M-I+1, K-1, -TAU( K ), + $ A( I, 1 ), LDA, A( I, K ), 1, CZERO, + $ AUXV( 1 ), 1 ) +* + CALL CGEMV( 'No transpose', N+NRHS, K-1, CONE, + $ F( 1, 1 ), LDF, AUXV( 1 ), 1, CONE, + $ F( 1, K ), 1 ) + END IF +* +* =============================================================== +* +* Update the current I-th row of A: +* A(I,K+1:N+NRHS) := A(I,K+1:N+NRHS) +* - A(I,1:K)*F(K+1:N+NRHS,1:K)**H. +* + IF( K.LT.N+NRHS ) THEN + CALL CGEMM( 'No transpose', 'Conjugate transpose', + $ 1, N+NRHS-K, K, -CONE, A( I, 1 ), LDA, + $ F( K+1, 1 ), LDF, CONE, A( I, K+1 ), LDA ) + END IF +* + A( I, K ) = AIK +* +* Update the partial column 2-norms for the residual matrix, +* only if the residual matrix A(I+1:M,K+1:N) exists, i.e. +* when K < MINMNFACT = min( M-IOFFSET, N ). +* + IF( K.LT.MINMNFACT ) THEN +* + DO J = K + 1, N + IF( VN1( J ).NE.ZERO ) THEN +* +* NOTE: The following lines follow from the analysis in +* Lapack Working Note 176. +* + TEMP = ABS( A( I, J ) ) / VN1( J ) + TEMP = MAX( ZERO, ( ONE+TEMP )*( ONE-TEMP ) ) + TEMP2 = TEMP*( VN1( J ) / VN2( J ) )**2 + IF( TEMP2.LE.TOL3Z ) THEN +* +* At J-index, we have a difficult column for the +* update of the 2-norm. Save the index of the previous +* difficult column in IWORK(J-1). +* NOTE: ILSTCC > 1, threfore we can use IWORK only +* with N-1 elements, where the elements are +* shifted by 1 to the left. +* + IWORK( J-1 ) = LSTICC +* +* Set the index of the last difficult column LSTICC. +* + LSTICC = J +* + ELSE + VN1( J ) = VN1( J )*SQRT( TEMP ) + END IF + END IF + END DO +* + END IF +* +* End of while loop. +* + END DO +* +* Now, afler the loop: +* Set KB, the number of factorized columns in the block; +* Set IF, the number of processed rows in the block, which +* is the same as the number of processed rows in +* the original whole matrix A_orig, IF = IOFFSET + KB. +* + KB = K + IF = I +* +* Apply the block reflector to the residual of the matrix A +* and the residual of the right hand sides B, if the residual +* matrix and and/or the residual of the right hand sides +* exist, i.e. if the submatrix A(I+1:M,KB+1:N+NRHS) exists. +* This occurs when KB < MINMNUPDT = min( M-IOFFSET, N+NRHS ): +* +* A(IF+1:M,K+1:N+NRHS) := A(IF+1:M,KB+1:N+NRHS) - +* A(IF+1:M,1:KB) * F(KB+1:N+NRHS,1:KB)**H. +* + IF( KB.LT.MINMNUPDT ) THEN + CALL CGEMM( 'No transpose', 'Conjugate transpose', + $ M-IF, N+NRHS-KB, KB, -CONE, A( IF+1, 1 ), LDA, + $ F( KB+1, 1 ), LDF, CONE, A( IF+1, KB+1 ), LDA ) + END IF +* +* Recompute the 2-norm of the difficult columns. +* Loop over the index of the difficult columns from the largest +* to the smallest index. +* + DO WHILE( LSTICC.GT.0 ) +* +* LSTICC is the index of the last difficult column is greater +* than 1. +* ITEMP is the index of the previous difficult column. +* + ITEMP = IWORK( LSTICC-1 ) +* +* Compute the 2-norm explicilty for the last difficult column and +* save it in the partial and exact 2-norm vectors VN1 and VN2. +* +* NOTE: The computation of VN1( LSTICC ) relies on the fact that +* SCNRM2 does not fail on vectors with norm below the value of +* SQRT(SLAMCH('S')) +* + VN1( LSTICC ) = SCNRM2( M-IF, A( IF+1, LSTICC ), 1 ) + VN2( LSTICC ) = VN1( LSTICC ) +* +* Downdate the index of the last difficult column to +* the index of the previous difficult column. +* + LSTICC = ITEMP +* + END DO +* + RETURN +* +* End of CLAQP3RK +* + END diff --git a/lapack-netlib/SRC/dgeqp3rk.f b/lapack-netlib/SRC/dgeqp3rk.f new file mode 100644 index 000000000..ace97b712 --- /dev/null +++ b/lapack-netlib/SRC/dgeqp3rk.f @@ -0,0 +1,1081 @@ +*> \brief \b DGEQP3RK computes a truncated Householder QR factorization with column pivoting of a real m-by-n matrix A by using Level 3 BLAS and overwrites a real m-by-nrhs matrix B with Q**T * B. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGEQP3RK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, A, LDA, +* $ K, MAXC2NRMK, RELMAXC2NRMK, JPIV, TAU, +* $ WORK, LWORK, IWORK, INFO ) +* IMPLICIT NONE +* +* .. Scalar Arguments .. +* INTEGER INFO, K, KMAX, LDA, LWORK, M, N, NRHS +* DOUBLE PRECISION ABSTOL, MAXC2NRMK, RELMAXC2NRMK, RELTOL +* .. +* .. Array Arguments .. +* INTEGER IWORK( * ), JPIV( * ) +* DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGEQP3RK performs two tasks simultaneously: +*> +*> Task 1: The routine computes a truncated (rank K) or full rank +*> Householder QR factorization with column pivoting of a real +*> M-by-N matrix A using Level 3 BLAS. K is the number of columns +*> that were factorized, i.e. factorization rank of the +*> factor R, K <= min(M,N). +*> +*> A * P(K) = Q(K) * R(K) = +*> +*> = Q(K) * ( R11(K) R12(K) ) = Q(K) * ( R(K)_approx ) +*> ( 0 R22(K) ) ( 0 R(K)_residual ), +*> +*> where: +*> +*> P(K) is an N-by-N permutation matrix; +*> Q(K) is an M-by-M orthogonal matrix; +*> R(K)_approx = ( R11(K), R12(K) ) is a rank K approximation of the +*> full rank factor R with K-by-K upper-triangular +*> R11(K) and K-by-N rectangular R12(K). The diagonal +*> entries of R11(K) appear in non-increasing order +*> of absolute value, and absolute values of all of +*> them exceed the maximum column 2-norm of R22(K) +*> up to roundoff error. +*> R(K)_residual = R22(K) is the residual of a rank K approximation +*> of the full rank factor R. It is a +*> an (M-K)-by-(N-K) rectangular matrix; +*> 0 is a an (M-K)-by-K zero matrix. +*> +*> Task 2: At the same time, the routine overwrites a real M-by-NRHS +*> matrix B with Q(K)**T * B using Level 3 BLAS. +*> +*> ===================================================================== +*> +*> The matrices A and B are stored on input in the array A as +*> the left and right blocks A(1:M,1:N) and A(1:M, N+1:N+NRHS) +*> respectively. +*> +*> N NRHS +*> array_A = M [ mat_A, mat_B ] +*> +*> The truncation criteria (i.e. when to stop the factorization) +*> can be any of the following: +*> +*> 1) The input parameter KMAX, the maximum number of columns +*> KMAX to factorize, i.e. the factorization rank is limited +*> to KMAX. If KMAX >= min(M,N), the criterion is not used. +*> +*> 2) The input parameter ABSTOL, the absolute tolerance for +*> the maximum column 2-norm of the residual matrix R22(K). This +*> means that the factorization stops if this norm is less or +*> equal to ABSTOL. If ABSTOL < 0.0, the criterion is not used. +*> +*> 3) The input parameter RELTOL, the tolerance for the maximum +*> column 2-norm matrix of the residual matrix R22(K) divided +*> by the maximum column 2-norm of the original matrix A, which +*> is equal to abs(R(1,1)). This means that the factorization stops +*> when the ratio of the maximum column 2-norm of R22(K) to +*> the maximum column 2-norm of A is less than or equal to RELTOL. +*> If RELTOL < 0.0, the criterion is not used. +*> +*> 4) In case both stopping criteria ABSTOL or RELTOL are not used, +*> and when the residual matrix R22(K) is a zero matrix in some +*> factorization step K. ( This stopping criterion is implicit. ) +*> +*> The algorithm stops when any of these conditions is first +*> satisfied, otherwise the whole matrix A is factorized. +*> +*> To factorize the whole matrix A, use the values +*> KMAX >= min(M,N), ABSTOL < 0.0 and RELTOL < 0.0. +*> +*> The routine returns: +*> a) Q(K), R(K)_approx = ( R11(K), R12(K) ), +*> R(K)_residual = R22(K), P(K), i.e. the resulting matrices +*> of the factorization; P(K) is represented by JPIV, +*> ( if K = min(M,N), R(K)_approx is the full factor R, +*> and there is no residual matrix R(K)_residual); +*> b) K, the number of columns that were factorized, +*> i.e. factorization rank; +*> c) MAXC2NRMK, the maximum column 2-norm of the residual +*> matrix R(K)_residual = R22(K), +*> ( if K = min(M,N), MAXC2NRMK = 0.0 ); +*> d) RELMAXC2NRMK equals MAXC2NRMK divided by MAXC2NRM, the maximum +*> column 2-norm of the original matrix A, which is equal +*> to abs(R(1,1)), ( if K = min(M,N), RELMAXC2NRMK = 0.0 ); +*> e) Q(K)**T * B, the matrix B with the orthogonal +*> transformation Q(K)**T applied on the left. +*> +*> The N-by-N permutation matrix P(K) is stored in a compact form in +*> the integer array JPIV. For 1 <= j <= N, column j +*> of the matrix A was interchanged with column JPIV(j). +*> +*> The M-by-M orthogonal matrix Q is represented as a product +*> of elementary Householder reflectors +*> +*> Q(K) = H(1) * H(2) * . . . * H(K), +*> +*> where K is the number of columns that were factorized. +*> +*> Each H(j) has the form +*> +*> H(j) = I - tau * v * v**T, +*> +*> where 1 <= j <= K and +*> I is an M-by-M identity matrix, +*> tau is a real scalar, +*> v is a real vector with v(1:j-1) = 0 and v(j) = 1. +*> +*> v(j+1:M) is stored on exit in A(j+1:M,j) and tau in TAU(j). +*> +*> See the Further Details section for more information. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e. the number of +*> columns of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in] KMAX +*> \verbatim +*> KMAX is INTEGER +*> +*> The first factorization stopping criterion. KMAX >= 0. +*> +*> The maximum number of columns of the matrix A to factorize, +*> i.e. the maximum factorization rank. +*> +*> a) If KMAX >= min(M,N), then this stopping criterion +*> is not used, the routine factorizes columns +*> depending on ABSTOL and RELTOL. +*> +*> b) If KMAX = 0, then this stopping criterion is +*> satisfied on input and the routine exits immediately. +*> This means that the factorization is not performed, +*> the matrices A and B are not modified, and +*> the matrix A is itself the residual. +*> \endverbatim +*> +*> \param[in] ABSTOL +*> \verbatim +*> ABSTOL is DOUBLE PRECISION +*> +*> The second factorization stopping criterion, cannot be NaN. +*> +*> The absolute tolerance (stopping threshold) for +*> maximum column 2-norm of the residual matrix R22(K). +*> The algorithm converges (stops the factorization) when +*> the maximum column 2-norm of the residual matrix R22(K) +*> is less than or equal to ABSTOL. Let SAFMIN = DLAMCH('S'). +*> +*> a) If ABSTOL is NaN, then no computation is performed +*> and an error message ( INFO = -5 ) is issued +*> by XERBLA. +*> +*> b) If ABSTOL < 0.0, then this stopping criterion is not +*> used, the routine factorizes columns depending +*> on KMAX and RELTOL. +*> This includes the case ABSTOL = -Inf. +*> +*> c) If 0.0 <= ABSTOL < 2*SAFMIN, then ABSTOL = 2*SAFMIN +*> is used. This includes the case ABSTOL = -0.0. +*> +*> d) If 2*SAFMIN <= ABSTOL then the input value +*> of ABSTOL is used. +*> +*> Let MAXC2NRM be the maximum column 2-norm of the +*> whole original matrix A. +*> If ABSTOL chosen above is >= MAXC2NRM, then this +*> stopping criterion is satisfied on input and routine exits +*> immediately after MAXC2NRM is computed. The routine +*> returns MAXC2NRM in MAXC2NORMK, +*> and 1.0 in RELMAXC2NORMK. +*> This includes the case ABSTOL = +Inf. This means that the +*> factorization is not performed, the matrices A and B are not +*> modified, and the matrix A is itself the residual. +*> \endverbatim +*> +*> \param[in] RELTOL +*> \verbatim +*> RELTOL is DOUBLE PRECISION +*> +*> The third factorization stopping criterion, cannot be NaN. +*> +*> The tolerance (stopping threshold) for the ratio +*> abs(R(K+1,K+1))/abs(R(1,1)) of the maximum column 2-norm of +*> the residual matrix R22(K) to the maximum column 2-norm of +*> the original matrix A. The algorithm converges (stops the +*> factorization), when abs(R(K+1,K+1))/abs(R(1,1)) A is less +*> than or equal to RELTOL. Let EPS = DLAMCH('E'). +*> +*> a) If RELTOL is NaN, then no computation is performed +*> and an error message ( INFO = -6 ) is issued +*> by XERBLA. +*> +*> b) If RELTOL < 0.0, then this stopping criterion is not +*> used, the routine factorizes columns depending +*> on KMAX and ABSTOL. +*> This includes the case RELTOL = -Inf. +*> +*> c) If 0.0 <= RELTOL < EPS, then RELTOL = EPS is used. +*> This includes the case RELTOL = -0.0. +*> +*> d) If EPS <= RELTOL then the input value of RELTOL +*> is used. +*> +*> Let MAXC2NRM be the maximum column 2-norm of the +*> whole original matrix A. +*> If RELTOL chosen above is >= 1.0, then this stopping +*> criterion is satisfied on input and routine exits +*> immediately after MAXC2NRM is computed. +*> The routine returns MAXC2NRM in MAXC2NORMK, +*> and 1.0 in RELMAXC2NORMK. +*> This includes the case RELTOL = +Inf. This means that the +*> factorization is not performed, the matrices A and B are not +*> modified, and the matrix A is itself the residual. +*> +*> NOTE: We recommend that RELTOL satisfy +*> min( max(M,N)*EPS, sqrt(EPS) ) <= RELTOL +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N+NRHS) +*> +*> On entry: +*> +*> a) The subarray A(1:M,1:N) contains the M-by-N matrix A. +*> b) The subarray A(1:M,N+1:N+NRHS) contains the M-by-NRHS +*> matrix B. +*> +*> N NRHS +*> array_A = M [ mat_A, mat_B ] +*> +*> On exit: +*> +*> a) The subarray A(1:M,1:N) contains parts of the factors +*> of the matrix A: +*> +*> 1) If K = 0, A(1:M,1:N) contains the original matrix A. +*> 2) If K > 0, A(1:M,1:N) contains parts of the +*> factors: +*> +*> 1. The elements below the diagonal of the subarray +*> A(1:M,1:K) together with TAU(1:K) represent the +*> orthogonal matrix Q(K) as a product of K Householder +*> elementary reflectors. +*> +*> 2. The elements on and above the diagonal of +*> the subarray A(1:K,1:N) contain K-by-N +*> upper-trapezoidal matrix +*> R(K)_approx = ( R11(K), R12(K) ). +*> NOTE: If K=min(M,N), i.e. full rank factorization, +*> then R_approx(K) is the full factor R which +*> is upper-trapezoidal. If, in addition, M>=N, +*> then R is upper-triangular. +*> +*> 3. The subarray A(K+1:M,K+1:N) contains (M-K)-by-(N-K) +*> rectangular matrix R(K)_residual = R22(K). +*> +*> b) If NRHS > 0, the subarray A(1:M,N+1:N+NRHS) contains +*> the M-by-NRHS product Q(K)**T * B. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> This is the leading dimension for both matrices, A and B. +*> \endverbatim +*> +*> \param[out] K +*> \verbatim +*> K is INTEGER +*> Factorization rank of the matrix A, i.e. the rank of +*> the factor R, which is the same as the number of non-zero +*> rows of the factor R. 0 <= K <= min(M,KMAX,N). +*> +*> K also represents the number of non-zero Householder +*> vectors. +*> +*> NOTE: If K = 0, a) the arrays A and B are not modified; +*> b) the array TAU(1:min(M,N)) is set to ZERO, +*> if the matrix A does not contain NaN, +*> otherwise the elements TAU(1:min(M,N)) +*> are undefined; +*> c) the elements of the array JPIV are set +*> as follows: for j = 1:N, JPIV(j) = j. +*> \endverbatim +*> +*> \param[out] MAXC2NRMK +*> \verbatim +*> MAXC2NRMK is DOUBLE PRECISION +*> The maximum column 2-norm of the residual matrix R22(K), +*> when the factorization stopped at rank K. MAXC2NRMK >= 0. +*> +*> a) If K = 0, i.e. the factorization was not performed, +*> the matrix A was not modified and is itself a residual +*> matrix, then MAXC2NRMK equals the maximum column 2-norm +*> of the original matrix A. +*> +*> b) If 0 < K < min(M,N), then MAXC2NRMK is returned. +*> +*> c) If K = min(M,N), i.e. the whole matrix A was +*> factorized and there is no residual matrix, +*> then MAXC2NRMK = 0.0. +*> +*> NOTE: MAXC2NRMK in the factorization step K would equal +*> R(K+1,K+1) in the next factorization step K+1. +*> \endverbatim +*> +*> \param[out] RELMAXC2NRMK +*> \verbatim +*> RELMAXC2NRMK is DOUBLE PRECISION +*> The ratio MAXC2NRMK / MAXC2NRM of the maximum column +*> 2-norm of the residual matrix R22(K) (when the factorization +*> stopped at rank K) to the maximum column 2-norm of the +*> whole original matrix A. RELMAXC2NRMK >= 0. +*> +*> a) If K = 0, i.e. the factorization was not performed, +*> the matrix A was not modified and is itself a residual +*> matrix, then RELMAXC2NRMK = 1.0. +*> +*> b) If 0 < K < min(M,N), then +*> RELMAXC2NRMK = MAXC2NRMK / MAXC2NRM is returned. +*> +*> c) If K = min(M,N), i.e. the whole matrix A was +*> factorized and there is no residual matrix, +*> then RELMAXC2NRMK = 0.0. +*> +*> NOTE: RELMAXC2NRMK in the factorization step K would equal +*> abs(R(K+1,K+1))/abs(R(1,1)) in the next factorization +*> step K+1. +*> \endverbatim +*> +*> \param[out] JPIV +*> \verbatim +*> JPIV is INTEGER array, dimension (N) +*> Column pivot indices. For 1 <= j <= N, column j +*> of the matrix A was interchanged with column JPIV(j). +*> +*> The elements of the array JPIV(1:N) are always set +*> by the routine, for example, even when no columns +*> were factorized, i.e. when K = 0, the elements are +*> set as JPIV(j) = j for j = 1:N. +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION array, dimension (min(M,N)) +*> The scalar factors of the elementary reflectors. +*> +*> If 0 < K <= min(M,N), only the elements TAU(1:K) of +*> the array TAU are modified by the factorization. +*> After the factorization computed, if no NaN was found +*> during the factorization, the remaining elements +*> TAU(K+1:min(M,N)) are set to zero, otherwise the +*> elements TAU(K+1:min(M,N)) are not set and therefore +*> undefined. +*> ( If K = 0, all elements of TAU are set to zero, if +*> the matrix A does not contain NaN. ) +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. +*. LWORK >= (3*N + NRHS - 1) +*> For optimal performance LWORK >= (2*N + NB*( N+NRHS+1 )), +*> where NB is the optimal block size for DGEQP3RK returned +*> by ILAENV. Minimal block size MINNB=2. +*> +*> NOTE: The decision, whether to use unblocked BLAS 2 +*> or blocked BLAS 3 code is based not only on the dimension +*> LWORK of the availbale workspace WORK, but also also on the +*> matrix A dimension N via crossover point NX returned +*> by ILAENV. (For N less than NX, unblocked code should be +*> used.) +*> +*> 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] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (N-1). +*> Is a work array. ( IWORK is used to store indices +*> of "bad" columns for norm downdating in the residual +*> matrix in the blocked step auxiliary subroutine DLAQP3RK ). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> 1) INFO = 0: successful exit. +*> 2) INFO < 0: if INFO = -i, the i-th argument had an +*> illegal value. +*> 3) If INFO = j_1, where 1 <= j_1 <= N, then NaN was +*> detected and the routine stops the computation. +*> The j_1-th column of the matrix A or the j_1-th +*> element of array TAU contains the first occurrence +*> of NaN in the factorization step K+1 ( when K columns +*> have been factorized ). +*> +*> On exit: +*> K is set to the number of +*> factorized columns without +*> exception. +*> MAXC2NRMK is set to NaN. +*> RELMAXC2NRMK is set to NaN. +*> TAU(K+1:min(M,N)) is not set and contains undefined +*> elements. If j_1=K+1, TAU(K+1) +*> may contain NaN. +*> 4) If INFO = j_2, where N+1 <= j_2 <= 2*N, then no NaN +*> was detected, but +Inf (or -Inf) was detected and +*> the routine continues the computation until completion. +*> The (j_2-N)-th column of the matrix A contains the first +*> occurrence of +Inf (or -Inf) in the factorization +*> step K+1 ( when K columns have been factorized ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup geqp3rk +* +*> \par Further Details: +* ===================== +* +*> \verbatim +*> DGEQP3RK is based on the same BLAS3 Householder QR factorization +*> algorithm with column pivoting as in DGEQP3 routine which uses +*> DLARFG routine to generate Householder reflectors +*> for QR factorization. +*> +*> We can also write: +*> +*> A = A_approx(K) + A_residual(K) +*> +*> The low rank approximation matrix A(K)_approx from +*> the truncated QR factorization of rank K of the matrix A is: +*> +*> A(K)_approx = Q(K) * ( R(K)_approx ) * P(K)**T +*> ( 0 0 ) +*> +*> = Q(K) * ( R11(K) R12(K) ) * P(K)**T +*> ( 0 0 ) +*> +*> The residual A_residual(K) of the matrix A is: +*> +*> A_residual(K) = Q(K) * ( 0 0 ) * P(K)**T = +*> ( 0 R(K)_residual ) +*> +*> = Q(K) * ( 0 0 ) * P(K)**T +*> ( 0 R22(K) ) +*> +*> The truncated (rank K) factorization guarantees that +*> the maximum column 2-norm of A_residual(K) is less than +*> or equal to MAXC2NRMK up to roundoff error. +*> +*> NOTE: An approximation of the null vectors +*> of A can be easily computed from R11(K) +*> and R12(K): +*> +*> Null( A(K) )_approx = P * ( inv(R11(K)) * R12(K) ) +*> ( -I ) +*> +*> \endverbatim +* +*> \par References: +* ================ +*> [1] A Level 3 BLAS QR factorization algorithm with column pivoting developed in 1996. +*> G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain. +*> X. Sun, Computer Science Dept., Duke University, USA. +*> C. H. Bischof, Math. and Comp. Sci. Div., Argonne National Lab, USA. +*> A BLAS-3 version of the QR factorization with column pivoting. +*> LAPACK Working Note 114 +*> \htmlonly +*> https://www.netlib.org/lapack/lawnspdf/lawn114.pdf +*> \endhtmlonly +*> and in +*> SIAM J. Sci. Comput., 19(5):1486-1494, Sept. 1998. +*> \htmlonly +*> https://doi.org/10.1137/S1064827595296732 +*> \endhtmlonly +*> +*> [2] A partial column norm updating strategy developed in 2006. +*> Z. Drmac and Z. Bujanovic, Dept. of Math., University of Zagreb, Croatia. +*> On the failure of rank revealing QR factorization software – a case study. +*> LAPACK Working Note 176. +*> \htmlonly +*> http://www.netlib.org/lapack/lawnspdf/lawn176.pdf +*> \endhtmlonly +*> and in +*> ACM Trans. Math. Softw. 35, 2, Article 12 (July 2008), 28 pages. +*> \htmlonly +*> https://doi.org/10.1145/1377612.1377616 +*> \endhtmlonly +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> November 2023, Igor Kozachenko, James Demmel, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE DGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, A, LDA, + $ K, MAXC2NRMK, RELMAXC2NRMK, JPIV, TAU, + $ WORK, LWORK, IWORK, INFO ) + IMPLICIT NONE +* +* -- LAPACK computational routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER INFO, K, KF, KMAX, LDA, LWORK, M, N, NRHS + DOUBLE PRECISION ABSTOL, MAXC2NRMK, RELMAXC2NRMK, RELTOL +* .. +* .. Array Arguments .. + INTEGER IWORK( * ), JPIV( * ) + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER INB, INBMIN, IXOVER + PARAMETER ( INB = 1, INBMIN = 2, IXOVER = 3 ) + DOUBLE PRECISION ZERO, ONE, TWO + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY, DONE + INTEGER IINFO, IOFFSET, IWS, J, JB, JBF, JMAXB, JMAX, + $ JMAXC2NRM, KP1, LWKOPT, MINMN, N_SUB, NB, + $ NBMIN, NX + DOUBLE PRECISION EPS, HUGEVAL, MAXC2NRM, SAFMIN +* .. +* .. External Subroutines .. + EXTERNAL DLAQP2RK, DLAQP3RK, XERBLA +* .. +* .. External Functions .. + LOGICAL DISNAN + INTEGER IDAMAX, ILAENV + DOUBLE PRECISION DLAMCH, DNRM2 + EXTERNAL DISNAN, DLAMCH, DNRM2, IDAMAX, ILAENV +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE, MAX, MIN +* .. +* .. Executable Statements .. +* +* Test input arguments +* ==================== +* + INFO = 0 + LQUERY = ( LWORK.EQ.-1 ) + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -3 + ELSE IF( KMAX.LT.0 ) THEN + INFO = -4 + ELSE IF( DISNAN( ABSTOL ) ) THEN + INFO = -5 + ELSE IF( DISNAN( RELTOL ) ) THEN + INFO = -6 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -8 + END IF +* +* If the input parameters M, N, NRHS, KMAX, LDA are valid: +* a) Test the input workspace size LWORK for the minimum +* size requirement IWS. +* b) Determine the optimal block size NB and optimal +* workspace size LWKOPT to be returned in WORK(1) +* in case of (1) LWORK < IWS, (2) LQUERY = .TRUE., +* (3) when routine exits. +* Here, IWS is the miminum workspace required for unblocked +* code. +* + IF( INFO.EQ.0 ) THEN + MINMN = MIN( M, N ) + IF( MINMN.EQ.0 ) THEN + IWS = 1 + LWKOPT = 1 + ELSE +* +* Minimal workspace size in case of using only unblocked +* BLAS 2 code in DLAQP2RK. +* 1) DGEQP3RK and DLAQP2RK: 2*N to store full and partial +* column 2-norms. +* 2) DLAQP2RK: N+NRHS-1 to use in WORK array that is used +* in DLARF subroutine inside DLAQP2RK to apply an +* elementary reflector from the left. +* TOTAL_WORK_SIZE = 3*N + NRHS - 1 +* + IWS = 3*N + NRHS - 1 +* +* Assign to NB optimal block size. +* + NB = ILAENV( INB, 'DGEQP3RK', ' ', M, N, -1, -1 ) +* +* A formula for the optimal workspace size in case of using +* both unblocked BLAS 2 in DLAQP2RK and blocked BLAS 3 code +* in DLAQP3RK. +* 1) DGEQP3RK, DLAQP2RK, DLAQP3RK: 2*N to store full and +* partial column 2-norms. +* 2) DLAQP2RK: N+NRHS-1 to use in WORK array that is used +* in DLARF subroutine to apply an elementary reflector +* from the left. +* 3) DLAQP3RK: NB*(N+NRHS) to use in the work array F that +* is used to apply a block reflector from +* the left. +* 4) DLAQP3RK: NB to use in the auxilixary array AUX. +* Sizes (2) and ((3) + (4)) should intersect, therefore +* TOTAL_WORK_SIZE = 2*N + NB*( N+NRHS+1 ), given NBMIN=2. +* + LWKOPT = 2*N + NB*( N+NRHS+1 ) + END IF + WORK( 1 ) = DBLE( LWKOPT ) +* + IF( ( LWORK.LT.IWS ) .AND. .NOT.LQUERY ) THEN + INFO = -15 + END IF + END IF +* +* NOTE: The optimal workspace size is returned in WORK(1), if +* the input parameters M, N, NRHS, KMAX, LDA are valid. +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGEQP3RK', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible for M=0 or N=0. +* + IF( MINMN.EQ.0 ) THEN + K = 0 + MAXC2NRMK = ZERO + RELMAXC2NRMK = ZERO + WORK( 1 ) = DBLE( LWKOPT ) + RETURN + END IF +* +* ================================================================== +* +* Initialize column pivot array JPIV. +* + DO J = 1, N + JPIV( J ) = J + END DO +* +* ================================================================== +* +* Initialize storage for partial and exact column 2-norms. +* a) The elements WORK(1:N) are used to store partial column +* 2-norms of the matrix A, and may decrease in each computation +* step; initialize to the values of complete columns 2-norms. +* b) The elements WORK(N+1:2*N) are used to store complete column +* 2-norms of the matrix A, they are not changed during the +* computation; initialize the values of complete columns 2-norms. +* + DO J = 1, N + WORK( J ) = DNRM2( M, A( 1, J ), 1 ) + WORK( N+J ) = WORK( J ) + END DO +* +* ================================================================== +* +* Compute the pivot column index and the maximum column 2-norm +* for the whole original matrix stored in A(1:M,1:N). +* + KP1 = IDAMAX( N, WORK( 1 ), 1 ) + MAXC2NRM = WORK( KP1 ) +* +* ==================================================================. +* + IF( DISNAN( MAXC2NRM ) ) THEN +* +* Check if the matrix A contains NaN, set INFO parameter +* to the column number where the first NaN is found and return +* from the routine. +* + K = 0 + INFO = KP1 +* +* Set MAXC2NRMK and RELMAXC2NRMK to NaN. +* + MAXC2NRMK = MAXC2NRM + RELMAXC2NRMK = MAXC2NRM +* +* Array TAU is not set and contains undefined elements. +* + WORK( 1 ) = DBLE( LWKOPT ) + RETURN + END IF +* +* =================================================================== +* + IF( MAXC2NRM.EQ.ZERO ) THEN +* +* Check is the matrix A is a zero matrix, set array TAU and +* return from the routine. +* + K = 0 + MAXC2NRMK = ZERO + RELMAXC2NRMK = ZERO +* + DO J = 1, MINMN + TAU( J ) = ZERO + END DO +* + WORK( 1 ) = DBLE( LWKOPT ) + RETURN +* + END IF +* +* =================================================================== +* + HUGEVAL = DLAMCH( 'Overflow' ) +* + IF( MAXC2NRM.GT.HUGEVAL ) THEN +* +* Check if the matrix A contains +Inf or -Inf, set INFO parameter +* to the column number, where the first +/-Inf is found plus N, +* and continue the computation. +* + INFO = N + KP1 +* + END IF +* +* ================================================================== +* +* Quick return if possible for the case when the first +* stopping criterion is satisfied, i.e. KMAX = 0. +* + IF( KMAX.EQ.0 ) THEN + K = 0 + MAXC2NRMK = MAXC2NRM + RELMAXC2NRMK = ONE + DO J = 1, MINMN + TAU( J ) = ZERO + END DO + WORK( 1 ) = DBLE( LWKOPT ) + RETURN + END IF +* +* ================================================================== +* + EPS = DLAMCH('Epsilon') +* +* Adjust ABSTOL +* + IF( ABSTOL.GE.ZERO ) THEN + SAFMIN = DLAMCH('Safe minimum') + ABSTOL = MAX( ABSTOL, TWO*SAFMIN ) + END IF +* +* Adjust RELTOL +* + IF( RELTOL.GE.ZERO ) THEN + RELTOL = MAX( RELTOL, EPS ) + END IF +* +* =================================================================== +* +* JMAX is the maximum index of the column to be factorized, +* which is also limited by the first stopping criterion KMAX. +* + JMAX = MIN( KMAX, MINMN ) +* +* =================================================================== +* +* Quick return if possible for the case when the second or third +* stopping criterion for the whole original matrix is satified, +* i.e. MAXC2NRM <= ABSTOL or RELMAXC2NRM <= RELTOL +* (which is ONE <= RELTOL). +* + IF( MAXC2NRM.LE.ABSTOL .OR. ONE.LE.RELTOL ) THEN +* + K = 0 + MAXC2NRMK = MAXC2NRM + RELMAXC2NRMK = ONE +* + DO J = 1, MINMN + TAU( J ) = ZERO + END DO +* + WORK( 1 ) = DBLE( LWKOPT ) + RETURN + END IF +* +* ================================================================== +* Factorize columns +* ================================================================== +* +* Determine the block size. +* + NBMIN = 2 + NX = 0 +* + IF( ( NB.GT.1 ) .AND. ( NB.LT.MINMN ) ) THEN +* +* Determine when to cross over from blocked to unblocked code. +* (for N less than NX, unblocked code should be used). +* + NX = MAX( 0, ILAENV( IXOVER, 'DGEQP3RK', ' ', M, N, -1, -1 )) +* + IF( NX.LT.MINMN ) THEN +* +* Determine if workspace is large enough for blocked code. +* + IF( LWORK.LT.LWKOPT ) THEN +* +* Not enough workspace to use optimal block size that +* is currently stored in NB. +* Reduce NB and determine the minimum value of NB. +* + NB = ( LWORK-2*N ) / ( N+1 ) + NBMIN = MAX( 2, ILAENV( INBMIN, 'DGEQP3RK', ' ', M, N, + $ -1, -1 ) ) +* + END IF + END IF + END IF +* +* ================================================================== +* +* DONE is the boolean flag to rerpresent the case when the +* factorization completed in the block factorization routine, +* before the end of the block. +* + DONE = .FALSE. +* +* J is the column index. +* + J = 1 +* +* (1) Use blocked code initially. +* +* JMAXB is the maximum column index of the block, when the +* blocked code is used, is also limited by the first stopping +* criterion KMAX. +* + JMAXB = MIN( KMAX, MINMN - NX ) +* + IF( NB.GE.NBMIN .AND. NB.LT.JMAX .AND. JMAXB.GT.0 ) THEN +* +* Loop over the column blocks of the matrix A(1:M,1:JMAXB). Here: +* J is the column index of a column block; +* JB is the column block size to pass to block factorization +* routine in a loop step; +* JBF is the number of columns that were actually factorized +* that was returned by the block factorization routine +* in a loop step, JBF <= JB; +* N_SUB is the number of columns in the submatrix; +* IOFFSET is the number of rows that should not be factorized. +* + DO WHILE( J.LE.JMAXB ) +* + JB = MIN( NB, JMAXB-J+1 ) + N_SUB = N-J+1 + IOFFSET = J-1 +* +* Factorize JB columns among the columns A(J:N). +* + CALL DLAQP3RK( M, N_SUB, NRHS, IOFFSET, JB, ABSTOL, + $ RELTOL, KP1, MAXC2NRM, A( 1, J ), LDA, + $ DONE, JBF, MAXC2NRMK, RELMAXC2NRMK, + $ JPIV( J ), TAU( J ), + $ WORK( J ), WORK( N+J ), + $ WORK( 2*N+1 ), WORK( 2*N+JB+1 ), + $ N+NRHS-J+1, IWORK, IINFO ) +* +* Set INFO on the first occurence of Inf. +* + IF( IINFO.GT.N_SUB .AND. INFO.EQ.0 ) THEN + INFO = 2*IOFFSET + IINFO + END IF +* + IF( DONE ) THEN +* +* Either the submatrix is zero before the end of the +* column block, or ABSTOL or RELTOL criterion is +* satisfied before the end of the column block, we can +* return from the routine. Perform the following before +* returning: +* a) Set the number of factorized columns K, +* K = IOFFSET + JBF from the last call of blocked +* routine. +* NOTE: 1) MAXC2NRMK and RELMAXC2NRMK are returned +* by the block factorization routine; +* 2) The remaining TAUs are set to ZERO by the +* block factorization routine. +* + K = IOFFSET + JBF +* +* Set INFO on the first occurrence of NaN, NaN takes +* prcedence over Inf. +* + IF( IINFO.LE.N_SUB .AND. IINFO.GT.0 ) THEN + INFO = IOFFSET + IINFO + END IF +* +* Return from the routine. +* + WORK( 1 ) = DBLE( LWKOPT ) +* + RETURN +* + END IF +* + J = J + JBF +* + END DO +* + END IF +* +* Use unblocked code to factor the last or only block. +* J = JMAX+1 means we factorized the maximum possible number of +* columns, that is in ELSE clause we need to compute +* the MAXC2NORM and RELMAXC2NORM to return after we processed +* the blocks. +* + IF( J.LE.JMAX ) THEN +* +* N_SUB is the number of columns in the submatrix; +* IOFFSET is the number of rows that should not be factorized. +* + N_SUB = N-J+1 + IOFFSET = J-1 +* + CALL DLAQP2RK( M, N_SUB, NRHS, IOFFSET, JMAX-J+1, + $ ABSTOL, RELTOL, KP1, MAXC2NRM, A( 1, J ), LDA, + $ KF, MAXC2NRMK, RELMAXC2NRMK, JPIV( J ), + $ TAU( J ), WORK( J ), WORK( N+J ), + $ WORK( 2*N+1 ), IINFO ) +* +* ABSTOL or RELTOL criterion is satisfied when the number of +* the factorized columns KF is smaller then the number +* of columns JMAX-J+1 supplied to be factorized by the +* unblocked routine, we can return from +* the routine. Perform the following before returning: +* a) Set the number of factorized columns K, +* b) MAXC2NRMK and RELMAXC2NRMK are returned by the +* unblocked factorization routine above. +* + K = J - 1 + KF +* +* Set INFO on the first exception occurence. +* +* Set INFO on the first exception occurence of Inf or NaN, +* (NaN takes precedence over Inf). +* + IF( IINFO.GT.N_SUB .AND. INFO.EQ.0 ) THEN + INFO = 2*IOFFSET + IINFO + ELSE IF( IINFO.LE.N_SUB .AND. IINFO.GT.0 ) THEN + INFO = IOFFSET + IINFO + END IF +* + ELSE +* +* Compute the return values for blocked code. +* +* Set the number of factorized columns if the unblocked routine +* was not called. +* + K = JMAX +* +* If there exits a residual matrix after the blocked code: +* 1) compute the values of MAXC2NRMK, RELMAXC2NRMK of the +* residual matrix, otherwise set them to ZERO; +* 2) Set TAU(K+1:MINMN) to ZERO. +* + IF( K.LT.MINMN ) THEN + JMAXC2NRM = K + IDAMAX( N-K, WORK( K+1 ), 1 ) + MAXC2NRMK = WORK( JMAXC2NRM ) + IF( K.EQ.0 ) THEN + RELMAXC2NRMK = ONE + ELSE + RELMAXC2NRMK = MAXC2NRMK / MAXC2NRM + END IF +* + DO J = K + 1, MINMN + TAU( J ) = ZERO + END DO +* + END IF +* +* END IF( J.LE.JMAX ) THEN +* + END IF +* + WORK( 1 ) = DBLE( LWKOPT ) +* + RETURN +* +* End of DGEQP3RK +* + END diff --git a/lapack-netlib/SRC/dlaqp2rk.f b/lapack-netlib/SRC/dlaqp2rk.f new file mode 100644 index 000000000..b5a84d0de --- /dev/null +++ b/lapack-netlib/SRC/dlaqp2rk.f @@ -0,0 +1,713 @@ +*> \brief \b DLAQP2RK computes truncated QR factorization with column pivoting of a real matrix block using Level 2 BLAS and overwrites a real m-by-nrhs matrix B with Q**T * B. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLAQP2RK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, +* $ KP1, MAXC2NRM, A, LDA, K, MAXC2NRMK, +* $ RELMAXC2NRMK, JPIV, TAU, VN1, VN2, WORK, +* $ INFO ) +* IMPLICIT NONE +* +* .. Scalar Arguments .. +* INTEGER INFO, IOFFSET, KP1, K, KMAX, LDA, M, N, NRHS +* DOUBLE PRECISION ABSTOL, MAXC2NRM, MAXC2NRMK, RELMAXC2NRMK, +* $ RELTOL +* .. +* .. Array Arguments .. +* INTEGER JPIV( * ) +* DOUBLE PRECISION A( LDA, * ), TAU( * ), VN1( * ), VN2( * ), +* $ WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLAQP2RK computes a truncated (rank K) or full rank Householder QR +*> factorization with column pivoting of a real matrix +*> block A(IOFFSET+1:M,1:N) as +*> +*> A * P(K) = Q(K) * R(K). +*> +*> The routine uses Level 2 BLAS. The block A(1:IOFFSET,1:N) +*> is accordingly pivoted, but not factorized. +*> +*> The routine also overwrites the right-hand-sides matrix block B +*> stored in A(IOFFSET+1:M,N+1:N+NRHS) with Q(K)**T * B. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of +*> columns of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in] IOFFSET +*> \verbatim +*> IOFFSET is INTEGER +*> The number of rows of the matrix A that must be pivoted +*> but not factorized. IOFFSET >= 0. +*> +*> IOFFSET also represents the number of columns of the whole +*> original matrix A_orig that have been factorized +*> in the previous steps. +*> \endverbatim +*> +*> \param[in] KMAX +*> \verbatim +*> KMAX is INTEGER +*> +*> The first factorization stopping criterion. KMAX >= 0. +*> +*> The maximum number of columns of the matrix A to factorize, +*> i.e. the maximum factorization rank. +*> +*> a) If KMAX >= min(M-IOFFSET,N), then this stopping +*> criterion is not used, factorize columns +*> depending on ABSTOL and RELTOL. +*> +*> b) If KMAX = 0, then this stopping criterion is +*> satisfied on input and the routine exits immediately. +*> This means that the factorization is not performed, +*> the matrices A and B and the arrays TAU, IPIV +*> are not modified. +*> \endverbatim +*> +*> \param[in] ABSTOL +*> \verbatim +*> ABSTOL is DOUBLE PRECISION, cannot be NaN. +*> +*> The second factorization stopping criterion. +*> +*> The absolute tolerance (stopping threshold) for +*> maximum column 2-norm of the residual matrix. +*> The algorithm converges (stops the factorization) when +*> the maximum column 2-norm of the residual matrix +*> is less than or equal to ABSTOL. +*> +*> a) If ABSTOL < 0.0, then this stopping criterion is not +*> used, the routine factorizes columns depending +*> on KMAX and RELTOL. +*> This includes the case ABSTOL = -Inf. +*> +*> b) If 0.0 <= ABSTOL then the input value +*> of ABSTOL is used. +*> \endverbatim +*> +*> \param[in] RELTOL +*> \verbatim +*> RELTOL is DOUBLE PRECISION, cannot be NaN. +*> +*> The third factorization stopping criterion. +*> +*> The tolerance (stopping threshold) for the ratio of the +*> maximum column 2-norm of the residual matrix to the maximum +*> column 2-norm of the original matrix A_orig. The algorithm +*> converges (stops the factorization), when this ratio is +*> less than or equal to RELTOL. +*> +*> a) If RELTOL < 0.0, then this stopping criterion is not +*> used, the routine factorizes columns depending +*> on KMAX and ABSTOL. +*> This includes the case RELTOL = -Inf. +*> +*> d) If 0.0 <= RELTOL then the input value of RELTOL +*> is used. +*> \endverbatim +*> +*> \param[in] KP1 +*> \verbatim +*> KP1 is INTEGER +*> The index of the column with the maximum 2-norm in +*> the whole original matrix A_orig determined in the +*> main routine DGEQP3RK. 1 <= KP1 <= N_orig_mat. +*> \endverbatim +*> +*> \param[in] MAXC2NRM +*> \verbatim +*> MAXC2NRM is DOUBLE PRECISION +*> The maximum column 2-norm of the whole original +*> matrix A_orig computed in the main routine DGEQP3RK. +*> MAXC2NRM >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N+NRHS) +*> On entry: +*> the M-by-N matrix A and M-by-NRHS matrix B, as in +*> +*> N NRHS +*> array_A = M [ mat_A, mat_B ] +*> +*> On exit: +*> 1. The elements in block A(IOFFSET+1:M,1:K) below +*> the diagonal together with the array TAU represent +*> the orthogonal matrix Q(K) as a product of elementary +*> reflectors. +*> 2. The upper triangular block of the matrix A stored +*> in A(IOFFSET+1:M,1:K) is the triangular factor obtained. +*> 3. The block of the matrix A stored in A(1:IOFFSET,1:N) +*> has been accordingly pivoted, but not factorized. +*> 4. The rest of the array A, block A(IOFFSET+1:M,K+1:N+NRHS). +*> The left part A(IOFFSET+1:M,K+1:N) of this block +*> contains the residual of the matrix A, and, +*> if NRHS > 0, the right part of the block +*> A(IOFFSET+1:M,N+1:N+NRHS) contains the block of +*> the right-hand-side matrix B. Both these blocks have been +*> updated by multiplication from the left by Q(K)**T. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] K +*> \verbatim +*> K is INTEGER +*> Factorization rank of the matrix A, i.e. the rank of +*> the factor R, which is the same as the number of non-zero +*> rows of the factor R. 0 <= K <= min(M-IOFFSET,KMAX,N). +*> +*> K also represents the number of non-zero Householder +*> vectors. +*> \endverbatim +*> +*> \param[out] MAXC2NRMK +*> \verbatim +*> MAXC2NRMK is DOUBLE PRECISION +*> The maximum column 2-norm of the residual matrix, +*> when the factorization stopped at rank K. MAXC2NRMK >= 0. +*> \endverbatim +*> +*> \param[out] RELMAXC2NRMK +*> \verbatim +*> RELMAXC2NRMK is DOUBLE PRECISION +*> The ratio MAXC2NRMK / MAXC2NRM of the maximum column +*> 2-norm of the residual matrix (when the factorization +*> stopped at rank K) to the maximum column 2-norm of the +*> whole original matrix A. RELMAXC2NRMK >= 0. +*> \endverbatim +*> +*> \param[out] JPIV +*> \verbatim +*> JPIV is INTEGER array, dimension (N) +*> Column pivot indices, for 1 <= j <= N, column j +*> of the matrix A was interchanged with column JPIV(j). +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION array, dimension (min(M-IOFFSET,N)) +*> The scalar factors of the elementary reflectors. +*> \endverbatim +*> +*> \param[in,out] VN1 +*> \verbatim +*> VN1 is DOUBLE PRECISION array, dimension (N) +*> The vector with the partial column norms. +*> \endverbatim +*> +*> \param[in,out] VN2 +*> \verbatim +*> VN2 is DOUBLE PRECISION array, dimension (N) +*> The vector with the exact column norms. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (N-1) +*> Used in DLARF subroutine to apply an elementary +*> reflector from the left. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> 1) INFO = 0: successful exit. +*> 2) If INFO = j_1, where 1 <= j_1 <= N, then NaN was +*> detected and the routine stops the computation. +*> The j_1-th column of the matrix A or the j_1-th +*> element of array TAU contains the first occurrence +*> of NaN in the factorization step K+1 ( when K columns +*> have been factorized ). +*> +*> On exit: +*> K is set to the number of +*> factorized columns without +*> exception. +*> MAXC2NRMK is set to NaN. +*> RELMAXC2NRMK is set to NaN. +*> TAU(K+1:min(M,N)) is not set and contains undefined +*> elements. If j_1=K+1, TAU(K+1) +*> may contain NaN. +*> 3) If INFO = j_2, where N+1 <= j_2 <= 2*N, then no NaN +*> was detected, but +Inf (or -Inf) was detected and +*> the routine continues the computation until completion. +*> The (j_2-N)-th column of the matrix A contains the first +*> occurrence of +Inf (or -Inf) in the factorization +*> step K+1 ( when K columns have been factorized ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup laqp2rk +* +*> \par References: +* ================ +*> [1] A Level 3 BLAS QR factorization algorithm with column pivoting developed in 1996. +*> G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain. +*> X. Sun, Computer Science Dept., Duke University, USA. +*> C. H. Bischof, Math. and Comp. Sci. Div., Argonne National Lab, USA. +*> A BLAS-3 version of the QR factorization with column pivoting. +*> LAPACK Working Note 114 +*> \htmlonly +*> https://www.netlib.org/lapack/lawnspdf/lawn114.pdf +*> \endhtmlonly +*> and in +*> SIAM J. Sci. Comput., 19(5):1486-1494, Sept. 1998. +*> \htmlonly +*> https://doi.org/10.1137/S1064827595296732 +*> \endhtmlonly +*> +*> [2] A partial column norm updating strategy developed in 2006. +*> Z. Drmac and Z. Bujanovic, Dept. of Math., University of Zagreb, Croatia. +*> On the failure of rank revealing QR factorization software – a case study. +*> LAPACK Working Note 176. +*> \htmlonly +*> http://www.netlib.org/lapack/lawnspdf/lawn176.pdf +*> \endhtmlonly +*> and in +*> ACM Trans. Math. Softw. 35, 2, Article 12 (July 2008), 28 pages. +*> \htmlonly +*> https://doi.org/10.1145/1377612.1377616 +*> \endhtmlonly +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> November 2023, Igor Kozachenko, James Demmel, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, + $ KP1, MAXC2NRM, A, LDA, K, MAXC2NRMK, + $ RELMAXC2NRMK, JPIV, TAU, VN1, VN2, WORK, + $ INFO ) + IMPLICIT NONE +* +* -- LAPACK auxiliary routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER INFO, IOFFSET, KP1, K, KMAX, LDA, M, N, NRHS + DOUBLE PRECISION ABSTOL, MAXC2NRM, MAXC2NRMK, RELMAXC2NRMK, + $ RELTOL +* .. +* .. Array Arguments .. + INTEGER JPIV( * ) + DOUBLE PRECISION A( LDA, * ), TAU( * ), VN1( * ), VN2( * ), + $ WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, ITEMP, J, JMAXC2NRM, KK, KP, MINMNFACT, + $ MINMNUPDT + DOUBLE PRECISION AIKK, HUGEVAL, TEMP, TEMP2, TOL3Z +* .. +* .. External Subroutines .. + EXTERNAL DLARF, DLARFG, DSWAP +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, SQRT +* .. +* .. External Functions .. + LOGICAL DISNAN + INTEGER IDAMAX + DOUBLE PRECISION DLAMCH, DNRM2 + EXTERNAL DISNAN, DLAMCH, IDAMAX, DNRM2 +* .. +* .. Executable Statements .. +* +* Initialize INFO +* + INFO = 0 +* +* MINMNFACT in the smallest dimension of the submatrix +* A(IOFFSET+1:M,1:N) to be factorized. +* +* MINMNUPDT is the smallest dimension +* of the subarray A(IOFFSET+1:M,1:N+NRHS) to be udated, which +* contains the submatrices A(IOFFSET+1:M,1:N) and +* B(IOFFSET+1:M,1:NRHS) as column blocks. +* + MINMNFACT = MIN( M-IOFFSET, N ) + MINMNUPDT = MIN( M-IOFFSET, N+NRHS ) + KMAX = MIN( KMAX, MINMNFACT ) + TOL3Z = SQRT( DLAMCH( 'Epsilon' ) ) + HUGEVAL = DLAMCH( 'Overflow' ) +* +* Compute the factorization, KK is the lomn loop index. +* + DO KK = 1, KMAX +* + I = IOFFSET + KK +* + IF( I.EQ.1 ) THEN +* +* ============================================================ +* +* We are at the first column of the original whole matrix A, +* therefore we use the computed KP1 and MAXC2NRM from the +* main routine. +* + + KP = KP1 +* +* ============================================================ +* + ELSE +* +* ============================================================ +* +* Determine the pivot column in KK-th step, i.e. the index +* of the column with the maximum 2-norm in the +* submatrix A(I:M,K:N). +* + KP = ( KK-1 ) + IDAMAX( N-KK+1, VN1( KK ), 1 ) +* +* Determine the maximum column 2-norm and the relative maximum +* column 2-norm of the submatrix A(I:M,KK:N) in step KK. +* RELMAXC2NRMK will be computed later, after somecondition +* checks on MAXC2NRMK. +* + MAXC2NRMK = VN1( KP ) +* +* ============================================================ +* +* Check if the submatrix A(I:M,KK:N) contains NaN, and set +* INFO parameter to the column number, where the first NaN +* is found and return from the routine. +* We need to check the condition only if the +* column index (same as row index) of the original whole +* matrix is larger than 1, since the condition for whole +* original matrix is checked in the main routine. +* + IF( DISNAN( MAXC2NRMK ) ) THEN +* +* Set K, the number of factorized columns. +* that are not zero. +* + K = KK - 1 + INFO = K + KP +* +* Set RELMAXC2NRMK to NaN. +* + RELMAXC2NRMK = MAXC2NRMK +* +* Array TAU(K+1:MINMNFACT) is not set and contains +* undefined elements. +* + RETURN + END IF +* +* ============================================================ +* +* Quick return, if the submatrix A(I:M,KK:N) is +* a zero matrix. +* We need to check the condition only if the +* column index (same as row index) of the original whole +* matrix is larger than 1, since the condition for whole +* original matrix is checked in the main routine. +* + IF( MAXC2NRMK.EQ.ZERO ) THEN +* +* Set K, the number of factorized columns. +* that are not zero. +* + K = KK - 1 + RELMAXC2NRMK = ZERO +* +* Set TAUs corresponding to the columns that were not +* factorized to ZERO, i.e. set TAU(KK:MINMNFACT) to ZERO. +* + DO J = KK, MINMNFACT + TAU( J ) = ZERO + END DO +* +* Return from the routine. +* + RETURN +* + END IF +* +* ============================================================ +* +* Check if the submatrix A(I:M,KK:N) contains Inf, +* set INFO parameter to the column number, where +* the first Inf is found plus N, and continue +* the computation. +* We need to check the condition only if the +* column index (same as row index) of the original whole +* matrix is larger than 1, since the condition for whole +* original matrix is checked in the main routine. +* + IF( INFO.EQ.0 .AND. MAXC2NRMK.GT.HUGEVAL ) THEN + INFO = N + KK - 1 + KP + END IF +* +* ============================================================ +* +* Test for the second and third stopping criteria. +* NOTE: There is no need to test for ABSTOL >= ZERO, since +* MAXC2NRMK is non-negative. Similarly, there is no need +* to test for RELTOL >= ZERO, since RELMAXC2NRMK is +* non-negative. +* We need to check the condition only if the +* column index (same as row index) of the original whole +* matrix is larger than 1, since the condition for whole +* original matrix is checked in the main routine. + + RELMAXC2NRMK = MAXC2NRMK / MAXC2NRM +* + IF( MAXC2NRMK.LE.ABSTOL .OR. RELMAXC2NRMK.LE.RELTOL ) THEN +* +* Set K, the number of factorized columns. +* + K = KK - 1 +* +* Set TAUs corresponding to the columns that were not +* factorized to ZERO, i.e. set TAU(KK:MINMNFACT) to ZERO. +* + DO J = KK, MINMNFACT + TAU( J ) = ZERO + END DO +* +* Return from the routine. +* + RETURN +* + END IF +* +* ============================================================ +* +* End ELSE of IF(I.EQ.1) +* + END IF +* +* =============================================================== +* +* If the pivot column is not the first column of the +* subblock A(1:M,KK:N): +* 1) swap the KK-th column and the KP-th pivot column +* in A(1:M,1:N); +* 2) copy the KK-th element into the KP-th element of the partial +* and exact 2-norm vectors VN1 and VN2. ( Swap is not needed +* for VN1 and VN2 since we use the element with the index +* larger than KK in the next loop step.) +* 3) Save the pivot interchange with the indices relative to the +* the original matrix A, not the block A(1:M,1:N). +* + IF( KP.NE.KK ) THEN + CALL DSWAP( M, A( 1, KP ), 1, A( 1, KK ), 1 ) + VN1( KP ) = VN1( KK ) + VN2( KP ) = VN2( KK ) + ITEMP = JPIV( KP ) + JPIV( KP ) = JPIV( KK ) + JPIV( KK ) = ITEMP + END IF +* +* Generate elementary reflector H(KK) using the column A(I:M,KK), +* if the column has more than one element, otherwise +* the elementary reflector would be an identity matrix, +* and TAU(KK) = ZERO. +* + IF( I.LT.M ) THEN + CALL DLARFG( M-I+1, A( I, KK ), A( I+1, KK ), 1, + $ TAU( KK ) ) + ELSE + TAU( KK ) = ZERO + END IF +* +* Check if TAU(KK) contains NaN, set INFO parameter +* to the column number where NaN is found and return from +* the routine. +* NOTE: There is no need to check TAU(KK) for Inf, +* since DLARFG cannot produce TAU(KK) or Householder vector +* below the diagonal containing Inf. Only BETA on the diagonal, +* returned by DLARFG can contain Inf, which requires +* TAU(KK) to contain NaN. Therefore, this case of generating Inf +* by DLARFG is covered by checking TAU(KK) for NaN. +* + IF( DISNAN( TAU(KK) ) ) THEN + K = KK - 1 + INFO = KK +* +* Set MAXC2NRMK and RELMAXC2NRMK to NaN. +* + MAXC2NRMK = TAU( KK ) + RELMAXC2NRMK = TAU( KK ) +* +* Array TAU(KK:MINMNFACT) is not set and contains +* undefined elements, except the first element TAU(KK) = NaN. +* + RETURN + END IF +* +* Apply H(KK)**T to A(I:M,KK+1:N+NRHS) from the left. +* ( If M >= N, then at KK = N there is no residual matrix, +* i.e. no columns of A to update, only columns of B. +* If M < N, then at KK = M-IOFFSET, I = M and we have a +* one-row residual matrix in A and the elementary +* reflector is a unit matrix, TAU(KK) = ZERO, i.e. no update +* is needed for the residual matrix in A and the +* right-hand-side-matrix in B. +* Therefore, we update only if +* KK < MINMNUPDT = min(M-IOFFSET, N+NRHS) +* condition is satisfied, not only KK < N+NRHS ) +* + IF( KK.LT.MINMNUPDT ) THEN + AIKK = A( I, KK ) + A( I, KK ) = ONE + CALL DLARF( 'Left', M-I+1, N+NRHS-KK, A( I, KK ), 1, + $ TAU( KK ), A( I, KK+1 ), LDA, WORK( 1 ) ) + A( I, KK ) = AIKK + END IF +* + IF( KK.LT.MINMNFACT ) THEN +* +* Update the partial column 2-norms for the residual matrix, +* only if the residual matrix A(I+1:M,KK+1:N) exists, i.e. +* when KK < min(M-IOFFSET, N). +* + DO J = KK + 1, N + IF( VN1( J ).NE.ZERO ) THEN +* +* NOTE: The following lines follow from the analysis in +* Lapack Working Note 176. +* + TEMP = ONE - ( ABS( A( I, J ) ) / VN1( J ) )**2 + TEMP = MAX( TEMP, ZERO ) + TEMP2 = TEMP*( VN1( J ) / VN2( J ) )**2 + IF( TEMP2 .LE. TOL3Z ) THEN +* +* Compute the column 2-norm for the partial +* column A(I+1:M,J) by explicitly computing it, +* and store it in both partial 2-norm vector VN1 +* and exact column 2-norm vector VN2. +* + VN1( J ) = DNRM2( M-I, A( I+1, J ), 1 ) + VN2( J ) = VN1( J ) +* + ELSE +* +* Update the column 2-norm for the partial +* column A(I+1:M,J) by removing one +* element A(I,J) and store it in partial +* 2-norm vector VN1. +* + VN1( J ) = VN1( J )*SQRT( TEMP ) +* + END IF + END IF + END DO +* + END IF +* +* End factorization loop +* + END DO +* +* If we reached this point, all colunms have been factorized, +* i.e. no condition was triggered to exit the routine. +* Set the number of factorized columns. +* + K = KMAX +* +* We reached the end of the loop, i.e. all KMAX columns were +* factorized, we need to set MAXC2NRMK and RELMAXC2NRMK before +* we return. +* + IF( K.LT.MINMNFACT ) THEN +* + JMAXC2NRM = K + IDAMAX( N-K, VN1( K+1 ), 1 ) + MAXC2NRMK = VN1( JMAXC2NRM ) +* + IF( K.EQ.0 ) THEN + RELMAXC2NRMK = ONE + ELSE + RELMAXC2NRMK = MAXC2NRMK / MAXC2NRM + END IF +* + ELSE + MAXC2NRMK = ZERO + RELMAXC2NRMK = ZERO + END IF +* +* We reached the end of the loop, i.e. all KMAX columns were +* factorized, set TAUs corresponding to the columns that were +* not factorized to ZERO, i.e. TAU(K+1:MINMNFACT) set to ZERO. +* + DO J = K + 1, MINMNFACT + TAU( J ) = ZERO + END DO +* + RETURN +* +* End of DLAQP2RK +* + END diff --git a/lapack-netlib/SRC/dlaqp3rk.f b/lapack-netlib/SRC/dlaqp3rk.f new file mode 100644 index 000000000..39e617d0e --- /dev/null +++ b/lapack-netlib/SRC/dlaqp3rk.f @@ -0,0 +1,935 @@ +*> \brief \b DLAQP3RK computes a step of truncated QR factorization with column pivoting of a real m-by-n matrix A using Level 3 BLAS and overwrites a real m-by-nrhs matrix B with Q**T * B. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLAQP3RK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, ABSTOL, +* $ RELTOL, KP1, MAXC2NRM, A, LDA, DONE, KB, +* $ MAXC2NRMK, RELMAXC2NRMK, JPIV, TAU, +* $ VN1, VN2, AUXV, F, LDF, IWORK, INFO ) +* IMPLICIT NONE +* LOGICAL DONE +* INTEGER INFO, IOFFSET, KB, KP1, LDA, LDF, M, N, +* $ NB, NRHS +* DOUBLE PRECISION ABSTOL, MAXC2NRM, MAXC2NRMK, RELMAXC2NRMK, +* $ RELTOL +* +* .. Scalar Arguments .. +* LOGICAL DONE +* INTEGER KB, LDA, LDF, M, N, NB, NRHS, IOFFSET +* DOUBLE PRECISION ABSTOL, MAXC2NRM, MAXC2NRMK, RELMAXC2NRMK, +* $ RELTOL +* .. +* .. Array Arguments .. +* INTEGER IWORK( * ), JPIV( * ) +* DOUBLE PRECISION A( LDA, * ), AUXV( * ), F( LDF, * ), TAU( * ), +* $ VN1( * ), VN2( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLAQP3RK computes a step of truncated QR factorization with column +*> pivoting of a real M-by-N matrix A block A(IOFFSET+1:M,1:N) +*> by using Level 3 BLAS as +*> +*> A * P(KB) = Q(KB) * R(KB). +*> +*> The routine tries to factorize NB columns from A starting from +*> the row IOFFSET+1 and updates the residual matrix with BLAS 3 +*> xGEMM. The number of actually factorized columns is returned +*> is smaller than NB. +*> +*> Block A(1:IOFFSET,1:N) is accordingly pivoted, but not factorized. +*> +*> The routine also overwrites the right-hand-sides B matrix stored +*> in A(IOFFSET+1:M,1:N+1:N+NRHS) with Q(KB)**T * B. +*> +*> Cases when the number of factorized columns KB < NB: +*> +*> (1) In some cases, due to catastrophic cancellations, it cannot +*> factorize all NB columns and need to update the residual matrix. +*> Hence, the actual number of factorized columns in the block returned +*> in KB is smaller than NB. The logical DONE is returned as FALSE. +*> The factorization of the whole original matrix A_orig must proceed +*> with the next block. +*> +*> (2) Whenever the stopping criterion ABSTOL or RELTOL is satisfied, +*> the factorization of the whole original matrix A_orig is stopped, +*> the logical DONE is returned as TRUE. The number of factorized +*> columns which is smaller than NB is returned in KB. +*> +*> (3) In case both stopping criteria ABSTOL or RELTOL are not used, +*> and when the residual matrix is a zero matrix in some factorization +*> step KB, the factorization of the whole original matrix A_orig is +*> stopped, the logical DONE is returned as TRUE. The number of +*> factorized columns which is smaller than NB is returned in KB. +*> +*> (4) Whenever NaN is detected in the matrix A or in the array TAU, +*> the factorization of the whole original matrix A_orig is stopped, +*> the logical DONE is returned as TRUE. The number of factorized +*> columns which is smaller than NB is returned in KB. The INFO +*> parameter is set to the column index of the first NaN occurrence. +*> +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0 +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of +*> columns of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in] IOFFSET +*> \verbatim +*> IOFFSET is INTEGER +*> The number of rows of the matrix A that must be pivoted +*> but not factorized. IOFFSET >= 0. +*> +*> IOFFSET also represents the number of columns of the whole +*> original matrix A_orig that have been factorized +*> in the previous steps. +*> \endverbatim +*> +*> \param[in] NB +*> \verbatim +*> NB is INTEGER +*> Factorization block size, i.e the number of columns +*> to factorize in the matrix A. 0 <= NB +*> +*> If NB = 0, then the routine exits immediately. +*> This means that the factorization is not performed, +*> the matrices A and B and the arrays TAU, IPIV +*> are not modified. +*> \endverbatim +*> +*> \param[in] ABSTOL +*> \verbatim +*> ABSTOL is DOUBLE PRECISION, cannot be NaN. +*> +*> The absolute tolerance (stopping threshold) for +*> maximum column 2-norm of the residual matrix. +*> The algorithm converges (stops the factorization) when +*> the maximum column 2-norm of the residual matrix +*> is less than or equal to ABSTOL. +*> +*> a) If ABSTOL < 0.0, then this stopping criterion is not +*> used, the routine factorizes columns depending +*> on NB and RELTOL. +*> This includes the case ABSTOL = -Inf. +*> +*> b) If 0.0 <= ABSTOL then the input value +*> of ABSTOL is used. +*> \endverbatim +*> +*> \param[in] RELTOL +*> \verbatim +*> RELTOL is DOUBLE PRECISION, cannot be NaN. +*> +*> The tolerance (stopping threshold) for the ratio of the +*> maximum column 2-norm of the residual matrix to the maximum +*> column 2-norm of the original matrix A_orig. The algorithm +*> converges (stops the factorization), when this ratio is +*> less than or equal to RELTOL. +*> +*> a) If RELTOL < 0.0, then this stopping criterion is not +*> used, the routine factorizes columns depending +*> on NB and ABSTOL. +*> This includes the case RELTOL = -Inf. +*> +*> d) If 0.0 <= RELTOL then the input value of RELTOL +*> is used. +*> \endverbatim +*> +*> \param[in] KP1 +*> \verbatim +*> KP1 is INTEGER +*> The index of the column with the maximum 2-norm in +*> the whole original matrix A_orig determined in the +*> main routine DGEQP3RK. 1 <= KP1 <= N_orig. +*> \endverbatim +*> +*> \param[in] MAXC2NRM +*> \verbatim +*> MAXC2NRM is DOUBLE PRECISION +*> The maximum column 2-norm of the whole original +*> matrix A_orig computed in the main routine DGEQP3RK. +*> MAXC2NRM >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N+NRHS) +*> On entry: +*> the M-by-N matrix A and M-by-NRHS matrix B, as in +*> +*> N NRHS +*> array_A = M [ mat_A, mat_B ] +*> +*> On exit: +*> 1. The elements in block A(IOFFSET+1:M,1:KB) below +*> the diagonal together with the array TAU represent +*> the orthogonal matrix Q(KB) as a product of elementary +*> reflectors. +*> 2. The upper triangular block of the matrix A stored +*> in A(IOFFSET+1:M,1:KB) is the triangular factor obtained. +*> 3. The block of the matrix A stored in A(1:IOFFSET,1:N) +*> has been accordingly pivoted, but not factorized. +*> 4. The rest of the array A, block A(IOFFSET+1:M,KB+1:N+NRHS). +*> The left part A(IOFFSET+1:M,KB+1:N) of this block +*> contains the residual of the matrix A, and, +*> if NRHS > 0, the right part of the block +*> A(IOFFSET+1:M,N+1:N+NRHS) contains the block of +*> the right-hand-side matrix B. Both these blocks have been +*> updated by multiplication from the left by Q(KB)**T. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] +*> \verbatim +*> DONE is LOGICAL +*> TRUE: a) if the factorization completed before processing +*> all min(M-IOFFSET,NB,N) columns due to ABSTOL +*> or RELTOL criterion, +*> b) if the factorization completed before processing +*> all min(M-IOFFSET,NB,N) columns due to the +*> residual matrix being a ZERO matrix. +*> c) when NaN was detected in the matrix A +*> or in the array TAU. +*> FALSE: otherwise. +*> \endverbatim +*> +*> \param[out] KB +*> \verbatim +*> KB is INTEGER +*> Factorization rank of the matrix A, i.e. the rank of +*> the factor R, which is the same as the number of non-zero +*> rows of the factor R. 0 <= KB <= min(M-IOFFSET,NB,N). +*> +*> KB also represents the number of non-zero Householder +*> vectors. +*> \endverbatim +*> +*> \param[out] MAXC2NRMK +*> \verbatim +*> MAXC2NRMK is DOUBLE PRECISION +*> The maximum column 2-norm of the residual matrix, +*> when the factorization stopped at rank KB. MAXC2NRMK >= 0. +*> \endverbatim +*> +*> \param[out] RELMAXC2NRMK +*> \verbatim +*> RELMAXC2NRMK is DOUBLE PRECISION +*> The ratio MAXC2NRMK / MAXC2NRM of the maximum column +*> 2-norm of the residual matrix (when the factorization +*> stopped at rank KB) to the maximum column 2-norm of the +*> original matrix A_orig. RELMAXC2NRMK >= 0. +*> \endverbatim +*> +*> \param[out] JPIV +*> \verbatim +*> JPIV is INTEGER array, dimension (N) +*> Column pivot indices, for 1 <= j <= N, column j +*> of the matrix A was interchanged with column JPIV(j). +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION array, dimension (min(M-IOFFSET,N)) +*> The scalar factors of the elementary reflectors. +*> \endverbatim +*> +*> \param[in,out] VN1 +*> \verbatim +*> VN1 is DOUBLE PRECISION array, dimension (N) +*> The vector with the partial column norms. +*> \endverbatim +*> +*> \param[in,out] VN2 +*> \verbatim +*> VN2 is DOUBLE PRECISION array, dimension (N) +*> The vector with the exact column norms. +*> \endverbatim +*> +*> \param[out] AUXV +*> \verbatim +*> AUXV is DOUBLE PRECISION array, dimension (NB) +*> Auxiliary vector. +*> \endverbatim +*> +*> \param[out] F +*> \verbatim +*> F is DOUBLE PRECISION array, dimension (LDF,NB) +*> Matrix F**T = L*(Y**T)*A. +*> \endverbatim +*> +*> \param[in] LDF +*> \verbatim +*> LDF is INTEGER +*> The leading dimension of the array F. LDF >= max(1,N+NRHS). +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (N-1). +*> Is a work array. ( IWORK is used to store indices +*> of "bad" columns for norm downdating in the residual +*> matrix ). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> 1) INFO = 0: successful exit. +*> 2) If INFO = j_1, where 1 <= j_1 <= N, then NaN was +*> detected and the routine stops the computation. +*> The j_1-th column of the matrix A or the j_1-th +*> element of array TAU contains the first occurrence +*> of NaN in the factorization step KB+1 ( when KB columns +*> have been factorized ). +*> +*> On exit: +*> KB is set to the number of +*> factorized columns without +*> exception. +*> MAXC2NRMK is set to NaN. +*> RELMAXC2NRMK is set to NaN. +*> TAU(KB+1:min(M,N)) is not set and contains undefined +*> elements. If j_1=KB+1, TAU(KB+1) +*> may contain NaN. +*> 3) If INFO = j_2, where N+1 <= j_2 <= 2*N, then no NaN +*> was detected, but +Inf (or -Inf) was detected and +*> the routine continues the computation until completion. +*> The (j_2-N)-th column of the matrix A contains the first +*> occurrence of +Inf (or -Inf) in the actorization +*> step KB+1 ( when KB columns have been factorized ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup laqp3rk +* +*> \par References: +* ================ +*> [1] A Level 3 BLAS QR factorization algorithm with column pivoting developed in 1996. +*> G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain. +*> X. Sun, Computer Science Dept., Duke University, USA. +*> C. H. Bischof, Math. and Comp. Sci. Div., Argonne National Lab, USA. +*> A BLAS-3 version of the QR factorization with column pivoting. +*> LAPACK Working Note 114 +*> \htmlonly +*> https://www.netlib.org/lapack/lawnspdf/lawn114.pdf +*> \endhtmlonly +*> and in +*> SIAM J. Sci. Comput., 19(5):1486-1494, Sept. 1998. +*> \htmlonly +*> https://doi.org/10.1137/S1064827595296732 +*> \endhtmlonly +*> +*> [2] A partial column norm updating strategy developed in 2006. +*> Z. Drmac and Z. Bujanovic, Dept. of Math., University of Zagreb, Croatia. +*> On the failure of rank revealing QR factorization software – a case study. +*> LAPACK Working Note 176. +*> \htmlonly +*> http://www.netlib.org/lapack/lawnspdf/lawn176.pdf +*> \endhtmlonly +*> and in +*> ACM Trans. Math. Softw. 35, 2, Article 12 (July 2008), 28 pages. +*> \htmlonly +*> https://doi.org/10.1145/1377612.1377616 +*> \endhtmlonly +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> November 2023, Igor Kozachenko, James Demmel, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, ABSTOL, + $ RELTOL, KP1, MAXC2NRM, A, LDA, DONE, KB, + $ MAXC2NRMK, RELMAXC2NRMK, JPIV, TAU, + $ VN1, VN2, AUXV, F, LDF, IWORK, INFO ) + IMPLICIT NONE +* +* -- LAPACK auxiliary routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + LOGICAL DONE + INTEGER INFO, IOFFSET, KB, KP1, LDA, LDF, M, N, + $ NB, NRHS + DOUBLE PRECISION ABSTOL, MAXC2NRM, MAXC2NRMK, RELMAXC2NRMK, + $ RELTOL +* .. +* .. Array Arguments .. + INTEGER IWORK( * ), JPIV( * ) + DOUBLE PRECISION A( LDA, * ), AUXV( * ), F( LDF, * ), TAU( * ), + $ VN1( * ), VN2( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER ITEMP, J, K, MINMNFACT, MINMNUPDT, + $ LSTICC, KP, I, IF + DOUBLE PRECISION AIK, HUGEVAL, TEMP, TEMP2, TOL3Z +* .. +* .. External Subroutines .. + EXTERNAL DGEMM, DGEMV, DLARFG, DSWAP +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, SQRT +* .. +* .. External Functions .. + LOGICAL DISNAN + INTEGER IDAMAX + DOUBLE PRECISION DLAMCH, DNRM2 + EXTERNAL DISNAN, DLAMCH, IDAMAX, DNRM2 +* .. +* .. Executable Statements .. +* +* Initialize INFO +* + INFO = 0 +* +* MINMNFACT in the smallest dimension of the submatrix +* A(IOFFSET+1:M,1:N) to be factorized. +* + MINMNFACT = MIN( M-IOFFSET, N ) + MINMNUPDT = MIN( M-IOFFSET, N+NRHS ) + NB = MIN( NB, MINMNFACT ) + TOL3Z = SQRT( DLAMCH( 'Epsilon' ) ) + HUGEVAL = DLAMCH( 'Overflow' ) +* +* Compute factorization in a while loop over NB columns, +* K is the column index in the block A(1:M,1:N). +* + K = 0 + LSTICC = 0 + DONE = .FALSE. +* + DO WHILE ( K.LT.NB .AND. LSTICC.EQ.0 ) + K = K + 1 + I = IOFFSET + K +* + IF( I.EQ.1 ) THEN +* +* We are at the first column of the original whole matrix A_orig, +* therefore we use the computed KP1 and MAXC2NRM from the +* main routine. +* + KP = KP1 +* + ELSE +* +* Determine the pivot column in K-th step, i.e. the index +* of the column with the maximum 2-norm in the +* submatrix A(I:M,K:N). +* + KP = ( K-1 ) + IDAMAX( N-K+1, VN1( K ), 1 ) +* +* Determine the maximum column 2-norm and the relative maximum +* column 2-norm of the submatrix A(I:M,K:N) in step K. +* + MAXC2NRMK = VN1( KP ) +* +* ============================================================ +* +* Check if the submatrix A(I:M,K:N) contains NaN, set +* INFO parameter to the column number, where the first NaN +* is found and return from the routine. +* We need to check the condition only if the +* column index (same as row index) of the original whole +* matrix is larger than 1, since the condition for whole +* original matrix is checked in the main routine. +* + IF( DISNAN( MAXC2NRMK ) ) THEN +* + DONE = .TRUE. +* +* Set KB, the number of factorized partial columns +* that are non-zero in each step in the block, +* i.e. the rank of the factor R. +* Set IF, the number of processed rows in the block, which +* is the same as the number of processed rows in +* the original whole matrix A_orig. +* + KB = K - 1 + IF = I - 1 + INFO = KB + KP +* +* Set RELMAXC2NRMK to NaN. +* + RELMAXC2NRMK = MAXC2NRMK +* +* There is no need to apply the block reflector to the +* residual of the matrix A stored in A(KB+1:M,KB+1:N), +* since the submatrix contains NaN and we stop +* the computation. +* But, we need to apply the block reflector to the residual +* right hand sides stored in A(KB+1:M,N+1:N+NRHS), if the +* residual right hand sides exist. This occurs +* when ( NRHS != 0 AND KB <= (M-IOFFSET) ): +* +* A(I+1:M,N+1:N+NRHS) := A(I+1:M,N+1:N+NRHS) - +* A(I+1:M,1:KB) * F(N+1:N+NRHS,1:KB)**T. + + IF( NRHS.GT.0 .AND. KB.LT.(M-IOFFSET) ) THEN + CALL DGEMM( 'No transpose', 'Transpose', + $ M-IF, NRHS, KB, -ONE, A( IF+1, 1 ), LDA, + $ F( N+1, 1 ), LDF, ONE, A( IF+1, N+1 ), LDA ) + END IF +* +* There is no need to recompute the 2-norm of the +* difficult columns, since we stop the factorization. +* +* Array TAU(KF+1:MINMNFACT) is not set and contains +* undefined elements. +* +* Return from the routine. +* + RETURN + END IF +* +* Quick return, if the submatrix A(I:M,K:N) is +* a zero matrix. We need to check it only if the column index +* (same as row index) is larger than 1, since the condition +* for the whole original matrix A_orig is checked in the main +* routine. +* + IF( MAXC2NRMK.EQ.ZERO ) THEN +* + DONE = .TRUE. +* +* Set KB, the number of factorized partial columns +* that are non-zero in each step in the block, +* i.e. the rank of the factor R. +* Set IF, the number of processed rows in the block, which +* is the same as the number of processed rows in +* the original whole matrix A_orig. +* + KB = K - 1 + IF = I - 1 + RELMAXC2NRMK = ZERO +* +* There is no need to apply the block reflector to the +* residual of the matrix A stored in A(KB+1:M,KB+1:N), +* since the submatrix is zero and we stop the computation. +* But, we need to apply the block reflector to the residual +* right hand sides stored in A(KB+1:M,N+1:N+NRHS), if the +* residual right hand sides exist. This occurs +* when ( NRHS != 0 AND KB <= (M-IOFFSET) ): +* +* A(I+1:M,N+1:N+NRHS) := A(I+1:M,N+1:N+NRHS) - +* A(I+1:M,1:KB) * F(N+1:N+NRHS,1:KB)**T. +* + IF( NRHS.GT.0 .AND. KB.LT.(M-IOFFSET) ) THEN + CALL DGEMM( 'No transpose', 'Transpose', + $ M-IF, NRHS, KB, -ONE, A( IF+1, 1 ), LDA, + $ F( N+1, 1 ), LDF, ONE, A( IF+1, N+1 ), LDA ) + END IF +* +* There is no need to recompute the 2-norm of the +* difficult columns, since we stop the factorization. +* +* Set TAUs corresponding to the columns that were not +* factorized to ZERO, i.e. set TAU(KB+1:MINMNFACT) = ZERO, +* which is equivalent to seting TAU(K:MINMNFACT) = ZERO. +* + DO J = K, MINMNFACT + TAU( J ) = ZERO + END DO +* +* Return from the routine. +* + RETURN +* + END IF +* +* ============================================================ +* +* Check if the submatrix A(I:M,K:N) contains Inf, +* set INFO parameter to the column number, where +* the first Inf is found plus N, and continue +* the computation. +* We need to check the condition only if the +* column index (same as row index) of the original whole +* matrix is larger than 1, since the condition for whole +* original matrix is checked in the main routine. +* + IF( INFO.EQ.0 .AND. MAXC2NRMK.GT.HUGEVAL ) THEN + INFO = N + K - 1 + KP + END IF +* +* ============================================================ +* +* Test for the second and third tolerance stopping criteria. +* NOTE: There is no need to test for ABSTOL.GE.ZERO, since +* MAXC2NRMK is non-negative. Similarly, there is no need +* to test for RELTOL.GE.ZERO, since RELMAXC2NRMK is +* non-negative. +* We need to check the condition only if the +* column index (same as row index) of the original whole +* matrix is larger than 1, since the condition for whole +* original matrix is checked in the main routine. +* + RELMAXC2NRMK = MAXC2NRMK / MAXC2NRM +* + IF( MAXC2NRMK.LE.ABSTOL .OR. RELMAXC2NRMK.LE.RELTOL ) THEN +* + DONE = .TRUE. +* +* Set KB, the number of factorized partial columns +* that are non-zero in each step in the block, +* i.e. the rank of the factor R. +* Set IF, the number of processed rows in the block, which +* is the same as the number of processed rows in +* the original whole matrix A_orig; +* + KB = K - 1 + IF = I - 1 +* +* Apply the block reflector to the residual of the +* matrix A and the residual of the right hand sides B, if +* the residual matrix and and/or the residual of the right +* hand sides exist, i.e. if the submatrix +* A(I+1:M,KB+1:N+NRHS) exists. This occurs when +* KB < MINMNUPDT = min( M-IOFFSET, N+NRHS ): +* +* A(IF+1:M,K+1:N+NRHS) := A(IF+1:M,KB+1:N+NRHS) - +* A(IF+1:M,1:KB) * F(KB+1:N+NRHS,1:KB)**T. +* + IF( KB.LT.MINMNUPDT ) THEN + CALL DGEMM( 'No transpose', 'Transpose', + $ M-IF, N+NRHS-KB, KB,-ONE, A( IF+1, 1 ), LDA, + $ F( KB+1, 1 ), LDF, ONE, A( IF+1, KB+1 ), LDA ) + END IF +* +* There is no need to recompute the 2-norm of the +* difficult columns, since we stop the factorization. +* +* Set TAUs corresponding to the columns that were not +* factorized to ZERO, i.e. set TAU(KB+1:MINMNFACT) = ZERO, +* which is equivalent to seting TAU(K:MINMNFACT) = ZERO. +* + DO J = K, MINMNFACT + TAU( J ) = ZERO + END DO +* +* Return from the routine. +* + RETURN +* + END IF +* +* ============================================================ +* +* End ELSE of IF(I.EQ.1) +* + END IF +* +* =============================================================== +* +* If the pivot column is not the first column of the +* subblock A(1:M,K:N): +* 1) swap the K-th column and the KP-th pivot column +* in A(1:M,1:N); +* 2) swap the K-th row and the KP-th row in F(1:N,1:K-1) +* 3) copy the K-th element into the KP-th element of the partial +* and exact 2-norm vectors VN1 and VN2. (Swap is not needed +* for VN1 and VN2 since we use the element with the index +* larger than K in the next loop step.) +* 4) Save the pivot interchange with the indices relative to the +* the original matrix A_orig, not the block A(1:M,1:N). +* + IF( KP.NE.K ) THEN + CALL DSWAP( M, A( 1, KP ), 1, A( 1, K ), 1 ) + CALL DSWAP( K-1, F( KP, 1 ), LDF, F( K, 1 ), LDF ) + VN1( KP ) = VN1( K ) + VN2( KP ) = VN2( K ) + ITEMP = JPIV( KP ) + JPIV( KP ) = JPIV( K ) + JPIV( K ) = ITEMP + END IF +* +* Apply previous Householder reflectors to column K: +* A(I:M,K) := A(I:M,K) - A(I:M,1:K-1)*F(K,1:K-1)**T. +* + IF( K.GT.1 ) THEN + CALL DGEMV( 'No transpose', M-I+1, K-1, -ONE, A( I, 1 ), + $ LDA, F( K, 1 ), LDF, ONE, A( I, K ), 1 ) + END IF +* +* Generate elementary reflector H(k) using the column A(I:M,K). +* + IF( I.LT.M ) THEN + CALL DLARFG( M-I+1, A( I, K ), A( I+1, K ), 1, TAU( K ) ) + ELSE + TAU( K ) = ZERO + END IF +* +* Check if TAU(K) contains NaN, set INFO parameter +* to the column number where NaN is found and return from +* the routine. +* NOTE: There is no need to check TAU(K) for Inf, +* since DLARFG cannot produce TAU(K) or Householder vector +* below the diagonal containing Inf. Only BETA on the diagonal, +* returned by DLARFG can contain Inf, which requires +* TAU(K) to contain NaN. Therefore, this case of generating Inf +* by DLARFG is covered by checking TAU(K) for NaN. +* + IF( DISNAN( TAU(K) ) ) THEN +* + DONE = .TRUE. +* +* Set KB, the number of factorized partial columns +* that are non-zero in each step in the block, +* i.e. the rank of the factor R. +* Set IF, the number of processed rows in the block, which +* is the same as the number of processed rows in +* the original whole matrix A_orig. +* + KB = K - 1 + IF = I - 1 + INFO = K +* +* Set MAXC2NRMK and RELMAXC2NRMK to NaN. +* + MAXC2NRMK = TAU( K ) + RELMAXC2NRMK = TAU( K ) +* +* There is no need to apply the block reflector to the +* residual of the matrix A stored in A(KB+1:M,KB+1:N), +* since the submatrix contains NaN and we stop +* the computation. +* But, we need to apply the block reflector to the residual +* right hand sides stored in A(KB+1:M,N+1:N+NRHS), if the +* residual right hand sides exist. This occurs +* when ( NRHS != 0 AND KB <= (M-IOFFSET) ): +* +* A(I+1:M,N+1:N+NRHS) := A(I+1:M,N+1:N+NRHS) - +* A(I+1:M,1:KB) * F(N+1:N+NRHS,1:KB)**T. +* + IF( NRHS.GT.0 .AND. KB.LT.(M-IOFFSET) ) THEN + CALL DGEMM( 'No transpose', 'Transpose', + $ M-IF, NRHS, KB, -ONE, A( IF+1, 1 ), LDA, + $ F( N+1, 1 ), LDF, ONE, A( IF+1, N+1 ), LDA ) + END IF +* +* There is no need to recompute the 2-norm of the +* difficult columns, since we stop the factorization. +* +* Array TAU(KF+1:MINMNFACT) is not set and contains +* undefined elements. +* +* Return from the routine. +* + RETURN + END IF +* +* =============================================================== +* + AIK = A( I, K ) + A( I, K ) = ONE +* +* =============================================================== +* +* Compute the current K-th column of F: +* 1) F(K+1:N,K) := tau(K) * A(I:M,K+1:N)**T * A(I:M,K). +* + IF( K.LT.N+NRHS ) THEN + CALL DGEMV( 'Transpose', M-I+1, N+NRHS-K, + $ TAU( K ), A( I, K+1 ), LDA, A( I, K ), 1, + $ ZERO, F( K+1, K ), 1 ) + END IF +* +* 2) Zero out elements above and on the diagonal of the +* column K in matrix F, i.e elements F(1:K,K). +* + DO J = 1, K + F( J, K ) = ZERO + END DO +* +* 3) Incremental updating of the K-th column of F: +* F(1:N,K) := F(1:N,K) - tau(K) * F(1:N,1:K-1) * A(I:M,1:K-1)**T +* * A(I:M,K). +* + IF( K.GT.1 ) THEN + CALL DGEMV( 'Transpose', M-I+1, K-1, -TAU( K ), + $ A( I, 1 ), LDA, A( I, K ), 1, ZERO, + $ AUXV( 1 ), 1 ) +* + CALL DGEMV( 'No transpose', N+NRHS, K-1, ONE, + $ F( 1, 1 ), LDF, AUXV( 1 ), 1, ONE, + $ F( 1, K ), 1 ) + END IF +* +* =============================================================== +* +* Update the current I-th row of A: +* A(I,K+1:N+NRHS) := A(I,K+1:N+NRHS) +* - A(I,1:K)*F(K+1:N+NRHS,1:K)**T. +* + IF( K.LT.N+NRHS ) THEN + CALL DGEMV( 'No transpose', N+NRHS-K, K, -ONE, + $ F( K+1, 1 ), LDF, A( I, 1 ), LDA, ONE, + $ A( I, K+1 ), LDA ) + END IF +* + A( I, K ) = AIK +* +* Update the partial column 2-norms for the residual matrix, +* only if the residual matrix A(I+1:M,K+1:N) exists, i.e. +* when K < MINMNFACT = min( M-IOFFSET, N ). +* + IF( K.LT.MINMNFACT ) THEN +* + DO J = K + 1, N + IF( VN1( J ).NE.ZERO ) THEN +* +* NOTE: The following lines follow from the analysis in +* Lapack Working Note 176. +* + TEMP = ABS( A( I, J ) ) / VN1( J ) + TEMP = MAX( ZERO, ( ONE+TEMP )*( ONE-TEMP ) ) + TEMP2 = TEMP*( VN1( J ) / VN2( J ) )**2 + IF( TEMP2.LE.TOL3Z ) THEN +* +* At J-index, we have a difficult column for the +* update of the 2-norm. Save the index of the previous +* difficult column in IWORK(J-1). +* NOTE: ILSTCC > 1, threfore we can use IWORK only +* with N-1 elements, where the elements are +* shifted by 1 to the left. +* + IWORK( J-1 ) = LSTICC +* +* Set the index of the last difficult column LSTICC. +* + LSTICC = J +* + ELSE + VN1( J ) = VN1( J )*SQRT( TEMP ) + END IF + END IF + END DO +* + END IF +* +* End of while loop. +* + END DO +* +* Now, afler the loop: +* Set KB, the number of factorized columns in the block; +* Set IF, the number of processed rows in the block, which +* is the same as the number of processed rows in +* the original whole matrix A_orig, IF = IOFFSET + KB. +* + KB = K + IF = I +* +* Apply the block reflector to the residual of the matrix A +* and the residual of the right hand sides B, if the residual +* matrix and and/or the residual of the right hand sides +* exist, i.e. if the submatrix A(I+1:M,KB+1:N+NRHS) exists. +* This occurs when KB < MINMNUPDT = min( M-IOFFSET, N+NRHS ): +* +* A(IF+1:M,K+1:N+NRHS) := A(IF+1:M,KB+1:N+NRHS) - +* A(IF+1:M,1:KB) * F(KB+1:N+NRHS,1:KB)**T. +* + IF( KB.LT.MINMNUPDT ) THEN + CALL DGEMM( 'No transpose', 'Transpose', + $ M-IF, N+NRHS-KB, KB, -ONE, A( IF+1, 1 ), LDA, + $ F( KB+1, 1 ), LDF, ONE, A( IF+1, KB+1 ), LDA ) + END IF +* +* Recompute the 2-norm of the difficult columns. +* Loop over the index of the difficult columns from the largest +* to the smallest index. +* + DO WHILE( LSTICC.GT.0 ) +* +* LSTICC is the index of the last difficult column is greater +* than 1. +* ITEMP is the index of the previous difficult column. +* + ITEMP = IWORK( LSTICC-1 ) +* +* Compute the 2-norm explicilty for the last difficult column and +* save it in the partial and exact 2-norm vectors VN1 and VN2. +* +* NOTE: The computation of VN1( LSTICC ) relies on the fact that +* DNRM2 does not fail on vectors with norm below the value of +* SQRT(DLAMCH('S')) +* + VN1( LSTICC ) = DNRM2( M-IF, A( IF+1, LSTICC ), 1 ) + VN2( LSTICC ) = VN1( LSTICC ) +* +* Downdate the index of the last difficult column to +* the index of the previous difficult column. +* + LSTICC = ITEMP +* + END DO +* + RETURN +* +* End of DLAQP3RK +* + END diff --git a/lapack-netlib/SRC/ilaenv.f b/lapack-netlib/SRC/ilaenv.f index a639e0375..e74a2b35e 100644 --- a/lapack-netlib/SRC/ilaenv.f +++ b/lapack-netlib/SRC/ilaenv.f @@ -132,7 +132,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \ingroup OTHERauxiliary +*> \ingroup ilaenv * *> \par Further Details: * ===================== @@ -355,6 +355,12 @@ ELSE NB = 64 END IF + ELSE IF( SUBNAM( 4: 7 ).EQ.'QP3RK' ) THEN + IF( SNAME ) THEN + NB = 32 + ELSE + NB = 32 + END IF END IF ELSE IF( C2.EQ.'PO' ) THEN IF( C3.EQ.'TRF' ) THEN @@ -541,7 +547,14 @@ ELSE NBMIN = 2 END IF + ELSE IF( SUBNAM( 4: 7 ).EQ.'QP3RK' ) THEN + IF( SNAME ) THEN + NBMIN = 2 + ELSE + NBMIN = 2 + END IF END IF + ELSE IF( C2.EQ.'SY' ) THEN IF( C3.EQ.'TRF' ) THEN IF( SNAME ) THEN @@ -618,6 +631,12 @@ ELSE NX = 128 END IF + ELSE IF( SUBNAM( 4: 7 ).EQ.'QP3RK' ) THEN + IF( SNAME ) THEN + NX = 128 + ELSE + NX = 128 + END IF END IF ELSE IF( C2.EQ.'SY' ) THEN IF( SNAME .AND. C3.EQ.'TRD' ) THEN diff --git a/lapack-netlib/SRC/sgeqp3rk.f b/lapack-netlib/SRC/sgeqp3rk.f new file mode 100644 index 000000000..17559c7f4 --- /dev/null +++ b/lapack-netlib/SRC/sgeqp3rk.f @@ -0,0 +1,1081 @@ +*> \brief \b SGEQP3RK computes a truncated Householder QR factorization with column pivoting of a real m-by-n matrix A by using Level 3 BLAS and overwrites a real m-by-nrhs matrix B with Q**T * B. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download SGEQP3RK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE SGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, A, LDA, +* $ K, MAXC2NRMK, RELMAXC2NRMK, JPIV, TAU, +* $ WORK, LWORK, IWORK, INFO ) +* IMPLICIT NONE +* +* .. Scalar Arguments .. +* INTEGER INFO, K, KMAX, LDA, LWORK, M, N, NRHS +* REAL ABSTOL, MAXC2NRMK, RELMAXC2NRMK, RELTOL +* .. +* .. Array Arguments .. +* INTEGER IWORK( * ), JPIV( * ) +* REAL A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SGEQP3RK performs two tasks simultaneously: +*> +*> Task 1: The routine computes a truncated (rank K) or full rank +*> Householder QR factorization with column pivoting of a real +*> M-by-N matrix A using Level 3 BLAS. K is the number of columns +*> that were factorized, i.e. factorization rank of the +*> factor R, K <= min(M,N). +*> +*> A * P(K) = Q(K) * R(K) = +*> +*> = Q(K) * ( R11(K) R12(K) ) = Q(K) * ( R(K)_approx ) +*> ( 0 R22(K) ) ( 0 R(K)_residual ), +*> +*> where: +*> +*> P(K) is an N-by-N permutation matrix; +*> Q(K) is an M-by-M orthogonal matrix; +*> R(K)_approx = ( R11(K), R12(K) ) is a rank K approximation of the +*> full rank factor R with K-by-K upper-triangular +*> R11(K) and K-by-N rectangular R12(K). The diagonal +*> entries of R11(K) appear in non-increasing order +*> of absolute value, and absolute values of all of +*> them exceed the maximum column 2-norm of R22(K) +*> up to roundoff error. +*> R(K)_residual = R22(K) is the residual of a rank K approximation +*> of the full rank factor R. It is a +*> an (M-K)-by-(N-K) rectangular matrix; +*> 0 is a an (M-K)-by-K zero matrix. +*> +*> Task 2: At the same time, the routine overwrites a real M-by-NRHS +*> matrix B with Q(K)**T * B using Level 3 BLAS. +*> +*> ===================================================================== +*> +*> The matrices A and B are stored on input in the array A as +*> the left and right blocks A(1:M,1:N) and A(1:M, N+1:N+NRHS) +*> respectively. +*> +*> N NRHS +*> array_A = M [ mat_A, mat_B ] +*> +*> The truncation criteria (i.e. when to stop the factorization) +*> can be any of the following: +*> +*> 1) The input parameter KMAX, the maximum number of columns +*> KMAX to factorize, i.e. the factorization rank is limited +*> to KMAX. If KMAX >= min(M,N), the criterion is not used. +*> +*> 2) The input parameter ABSTOL, the absolute tolerance for +*> the maximum column 2-norm of the residual matrix R22(K). This +*> means that the factorization stops if this norm is less or +*> equal to ABSTOL. If ABSTOL < 0.0, the criterion is not used. +*> +*> 3) The input parameter RELTOL, the tolerance for the maximum +*> column 2-norm matrix of the residual matrix R22(K) divided +*> by the maximum column 2-norm of the original matrix A, which +*> is equal to abs(R(1,1)). This means that the factorization stops +*> when the ratio of the maximum column 2-norm of R22(K) to +*> the maximum column 2-norm of A is less than or equal to RELTOL. +*> If RELTOL < 0.0, the criterion is not used. +*> +*> 4) In case both stopping criteria ABSTOL or RELTOL are not used, +*> and when the residual matrix R22(K) is a zero matrix in some +*> factorization step K. ( This stopping criterion is implicit. ) +*> +*> The algorithm stops when any of these conditions is first +*> satisfied, otherwise the whole matrix A is factorized. +*> +*> To factorize the whole matrix A, use the values +*> KMAX >= min(M,N), ABSTOL < 0.0 and RELTOL < 0.0. +*> +*> The routine returns: +*> a) Q(K), R(K)_approx = ( R11(K), R12(K) ), +*> R(K)_residual = R22(K), P(K), i.e. the resulting matrices +*> of the factorization; P(K) is represented by JPIV, +*> ( if K = min(M,N), R(K)_approx is the full factor R, +*> and there is no residual matrix R(K)_residual); +*> b) K, the number of columns that were factorized, +*> i.e. factorization rank; +*> c) MAXC2NRMK, the maximum column 2-norm of the residual +*> matrix R(K)_residual = R22(K), +*> ( if K = min(M,N), MAXC2NRMK = 0.0 ); +*> d) RELMAXC2NRMK equals MAXC2NRMK divided by MAXC2NRM, the maximum +*> column 2-norm of the original matrix A, which is equal +*> to abs(R(1,1)), ( if K = min(M,N), RELMAXC2NRMK = 0.0 ); +*> e) Q(K)**T * B, the matrix B with the orthogonal +*> transformation Q(K)**T applied on the left. +*> +*> The N-by-N permutation matrix P(K) is stored in a compact form in +*> the integer array JPIV. For 1 <= j <= N, column j +*> of the matrix A was interchanged with column JPIV(j). +*> +*> The M-by-M orthogonal matrix Q is represented as a product +*> of elementary Householder reflectors +*> +*> Q(K) = H(1) * H(2) * . . . * H(K), +*> +*> where K is the number of columns that were factorized. +*> +*> Each H(j) has the form +*> +*> H(j) = I - tau * v * v**T, +*> +*> where 1 <= j <= K and +*> I is an M-by-M identity matrix, +*> tau is a real scalar, +*> v is a real vector with v(1:j-1) = 0 and v(j) = 1. +*> +*> v(j+1:M) is stored on exit in A(j+1:M,j) and tau in TAU(j). +*> +*> See the Further Details section for more information. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e. the number of +*> columns of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in] KMAX +*> \verbatim +*> KMAX is INTEGER +*> +*> The first factorization stopping criterion. KMAX >= 0. +*> +*> The maximum number of columns of the matrix A to factorize, +*> i.e. the maximum factorization rank. +*> +*> a) If KMAX >= min(M,N), then this stopping criterion +*> is not used, the routine factorizes columns +*> depending on ABSTOL and RELTOL. +*> +*> b) If KMAX = 0, then this stopping criterion is +*> satisfied on input and the routine exits immediately. +*> This means that the factorization is not performed, +*> the matrices A and B are not modified, and +*> the matrix A is itself the residual. +*> \endverbatim +*> +*> \param[in] ABSTOL +*> \verbatim +*> ABSTOL is REAL +*> +*> The second factorization stopping criterion, cannot be NaN. +*> +*> The absolute tolerance (stopping threshold) for +*> maximum column 2-norm of the residual matrix R22(K). +*> The algorithm converges (stops the factorization) when +*> the maximum column 2-norm of the residual matrix R22(K) +*> is less than or equal to ABSTOL. Let SAFMIN = SLAMCH('S'). +*> +*> a) If ABSTOL is NaN, then no computation is performed +*> and an error message ( INFO = -5 ) is issued +*> by XERBLA. +*> +*> b) If ABSTOL < 0.0, then this stopping criterion is not +*> used, the routine factorizes columns depending +*> on KMAX and RELTOL. +*> This includes the case ABSTOL = -Inf. +*> +*> c) If 0.0 <= ABSTOL < 2*SAFMIN, then ABSTOL = 2*SAFMIN +*> is used. This includes the case ABSTOL = -0.0. +*> +*> d) If 2*SAFMIN <= ABSTOL then the input value +*> of ABSTOL is used. +*> +*> Let MAXC2NRM be the maximum column 2-norm of the +*> whole original matrix A. +*> If ABSTOL chosen above is >= MAXC2NRM, then this +*> stopping criterion is satisfied on input and routine exits +*> immediately after MAXC2NRM is computed. The routine +*> returns MAXC2NRM in MAXC2NORMK, +*> and 1.0 in RELMAXC2NORMK. +*> This includes the case ABSTOL = +Inf. This means that the +*> factorization is not performed, the matrices A and B are not +*> modified, and the matrix A is itself the residual. +*> \endverbatim +*> +*> \param[in] RELTOL +*> \verbatim +*> RELTOL is REAL +*> +*> The third factorization stopping criterion, cannot be NaN. +*> +*> The tolerance (stopping threshold) for the ratio +*> abs(R(K+1,K+1))/abs(R(1,1)) of the maximum column 2-norm of +*> the residual matrix R22(K) to the maximum column 2-norm of +*> the original matrix A. The algorithm converges (stops the +*> factorization), when abs(R(K+1,K+1))/abs(R(1,1)) A is less +*> than or equal to RELTOL. Let EPS = SLAMCH('E'). +*> +*> a) If RELTOL is NaN, then no computation is performed +*> and an error message ( INFO = -6 ) is issued +*> by XERBLA. +*> +*> b) If RELTOL < 0.0, then this stopping criterion is not +*> used, the routine factorizes columns depending +*> on KMAX and ABSTOL. +*> This includes the case RELTOL = -Inf. +*> +*> c) If 0.0 <= RELTOL < EPS, then RELTOL = EPS is used. +*> This includes the case RELTOL = -0.0. +*> +*> d) If EPS <= RELTOL then the input value of RELTOL +*> is used. +*> +*> Let MAXC2NRM be the maximum column 2-norm of the +*> whole original matrix A. +*> If RELTOL chosen above is >= 1.0, then this stopping +*> criterion is satisfied on input and routine exits +*> immediately after MAXC2NRM is computed. +*> The routine returns MAXC2NRM in MAXC2NORMK, +*> and 1.0 in RELMAXC2NORMK. +*> This includes the case RELTOL = +Inf. This means that the +*> factorization is not performed, the matrices A and B are not +*> modified, and the matrix A is itself the residual. +*> +*> NOTE: We recommend that RELTOL satisfy +*> min( max(M,N)*EPS, sqrt(EPS) ) <= RELTOL +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is REAL array, dimension (LDA,N+NRHS) +*> +*> On entry: +*> +*> a) The subarray A(1:M,1:N) contains the M-by-N matrix A. +*> b) The subarray A(1:M,N+1:N+NRHS) contains the M-by-NRHS +*> matrix B. +*> +*> N NRHS +*> array_A = M [ mat_A, mat_B ] +*> +*> On exit: +*> +*> a) The subarray A(1:M,1:N) contains parts of the factors +*> of the matrix A: +*> +*> 1) If K = 0, A(1:M,1:N) contains the original matrix A. +*> 2) If K > 0, A(1:M,1:N) contains parts of the +*> factors: +*> +*> 1. The elements below the diagonal of the subarray +*> A(1:M,1:K) together with TAU(1:K) represent the +*> orthogonal matrix Q(K) as a product of K Householder +*> elementary reflectors. +*> +*> 2. The elements on and above the diagonal of +*> the subarray A(1:K,1:N) contain K-by-N +*> upper-trapezoidal matrix +*> R(K)_approx = ( R11(K), R12(K) ). +*> NOTE: If K=min(M,N), i.e. full rank factorization, +*> then R_approx(K) is the full factor R which +*> is upper-trapezoidal. If, in addition, M>=N, +*> then R is upper-triangular. +*> +*> 3. The subarray A(K+1:M,K+1:N) contains (M-K)-by-(N-K) +*> rectangular matrix R(K)_residual = R22(K). +*> +*> b) If NRHS > 0, the subarray A(1:M,N+1:N+NRHS) contains +*> the M-by-NRHS product Q(K)**T * B. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> This is the leading dimension for both matrices, A and B. +*> \endverbatim +*> +*> \param[out] K +*> \verbatim +*> K is INTEGER +*> Factorization rank of the matrix A, i.e. the rank of +*> the factor R, which is the same as the number of non-zero +*> rows of the factor R. 0 <= K <= min(M,KMAX,N). +*> +*> K also represents the number of non-zero Householder +*> vectors. +*> +*> NOTE: If K = 0, a) the arrays A and B are not modified; +*> b) the array TAU(1:min(M,N)) is set to ZERO, +*> if the matrix A does not contain NaN, +*> otherwise the elements TAU(1:min(M,N)) +*> are undefined; +*> c) the elements of the array JPIV are set +*> as follows: for j = 1:N, JPIV(j) = j. +*> \endverbatim +*> +*> \param[out] MAXC2NRMK +*> \verbatim +*> MAXC2NRMK is REAL +*> The maximum column 2-norm of the residual matrix R22(K), +*> when the factorization stopped at rank K. MAXC2NRMK >= 0. +*> +*> a) If K = 0, i.e. the factorization was not performed, +*> the matrix A was not modified and is itself a residual +*> matrix, then MAXC2NRMK equals the maximum column 2-norm +*> of the original matrix A. +*> +*> b) If 0 < K < min(M,N), then MAXC2NRMK is returned. +*> +*> c) If K = min(M,N), i.e. the whole matrix A was +*> factorized and there is no residual matrix, +*> then MAXC2NRMK = 0.0. +*> +*> NOTE: MAXC2NRMK in the factorization step K would equal +*> R(K+1,K+1) in the next factorization step K+1. +*> \endverbatim +*> +*> \param[out] RELMAXC2NRMK +*> \verbatim +*> RELMAXC2NRMK is REAL +*> The ratio MAXC2NRMK / MAXC2NRM of the maximum column +*> 2-norm of the residual matrix R22(K) (when the factorization +*> stopped at rank K) to the maximum column 2-norm of the +*> whole original matrix A. RELMAXC2NRMK >= 0. +*> +*> a) If K = 0, i.e. the factorization was not performed, +*> the matrix A was not modified and is itself a residual +*> matrix, then RELMAXC2NRMK = 1.0. +*> +*> b) If 0 < K < min(M,N), then +*> RELMAXC2NRMK = MAXC2NRMK / MAXC2NRM is returned. +*> +*> c) If K = min(M,N), i.e. the whole matrix A was +*> factorized and there is no residual matrix, +*> then RELMAXC2NRMK = 0.0. +*> +*> NOTE: RELMAXC2NRMK in the factorization step K would equal +*> abs(R(K+1,K+1))/abs(R(1,1)) in the next factorization +*> step K+1. +*> \endverbatim +*> +*> \param[out] JPIV +*> \verbatim +*> JPIV is INTEGER array, dimension (N) +*> Column pivot indices. For 1 <= j <= N, column j +*> of the matrix A was interchanged with column JPIV(j). +*> +*> The elements of the array JPIV(1:N) are always set +*> by the routine, for example, even when no columns +*> were factorized, i.e. when K = 0, the elements are +*> set as JPIV(j) = j for j = 1:N. +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is REAL array, dimension (min(M,N)) +*> The scalar factors of the elementary reflectors. +*> +*> If 0 < K <= min(M,N), only the elements TAU(1:K) of +*> the array TAU are modified by the factorization. +*> After the factorization computed, if no NaN was found +*> during the factorization, the remaining elements +*> TAU(K+1:min(M,N)) are set to zero, otherwise the +*> elements TAU(K+1:min(M,N)) are not set and therefore +*> undefined. +*> ( If K = 0, all elements of TAU are set to zero, if +*> the matrix A does not contain NaN. ) +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is REAL array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. +*. LWORK >= (3*N + NRHS - 1) +*> For optimal performance LWORK >= (2*N + NB*( N+NRHS+1 )), +*> where NB is the optimal block size for SGEQP3RK returned +*> by ILAENV. Minimal block size MINNB=2. +*> +*> NOTE: The decision, whether to use unblocked BLAS 2 +*> or blocked BLAS 3 code is based not only on the dimension +*> LWORK of the availbale workspace WORK, but also also on the +*> matrix A dimension N via crossover point NX returned +*> by ILAENV. (For N less than NX, unblocked code should be +*> used.) +*> +*> 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] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (N-1). +*> Is a work array. ( IWORK is used to store indices +*> of "bad" columns for norm downdating in the residual +*> matrix in the blocked step auxiliary subroutine SLAQP3RK ). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> 1) INFO = 0: successful exit. +*> 2) INFO < 0: if INFO = -i, the i-th argument had an +*> illegal value. +*> 3) If INFO = j_1, where 1 <= j_1 <= N, then NaN was +*> detected and the routine stops the computation. +*> The j_1-th column of the matrix A or the j_1-th +*> element of array TAU contains the first occurrence +*> of NaN in the factorization step K+1 ( when K columns +*> have been factorized ). +*> +*> On exit: +*> K is set to the number of +*> factorized columns without +*> exception. +*> MAXC2NRMK is set to NaN. +*> RELMAXC2NRMK is set to NaN. +*> TAU(K+1:min(M,N)) is not set and contains undefined +*> elements. If j_1=K+1, TAU(K+1) +*> may contain NaN. +*> 4) If INFO = j_2, where N+1 <= j_2 <= 2*N, then no NaN +*> was detected, but +Inf (or -Inf) was detected and +*> the routine continues the computation until completion. +*> The (j_2-N)-th column of the matrix A contains the first +*> occurrence of +Inf (or -Inf) in the factorization +*> step K+1 ( when K columns have been factorized ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup geqp3rk +* +*> \par Further Details: +* ===================== +* +*> \verbatim +*> SGEQP3RK is based on the same BLAS3 Householder QR factorization +*> algorithm with column pivoting as in SGEQP3 routine which uses +*> SLARFG routine to generate Householder reflectors +*> for QR factorization. +*> +*> We can also write: +*> +*> A = A_approx(K) + A_residual(K) +*> +*> The low rank approximation matrix A(K)_approx from +*> the truncated QR factorization of rank K of the matrix A is: +*> +*> A(K)_approx = Q(K) * ( R(K)_approx ) * P(K)**T +*> ( 0 0 ) +*> +*> = Q(K) * ( R11(K) R12(K) ) * P(K)**T +*> ( 0 0 ) +*> +*> The residual A_residual(K) of the matrix A is: +*> +*> A_residual(K) = Q(K) * ( 0 0 ) * P(K)**T = +*> ( 0 R(K)_residual ) +*> +*> = Q(K) * ( 0 0 ) * P(K)**T +*> ( 0 R22(K) ) +*> +*> The truncated (rank K) factorization guarantees that +*> the maximum column 2-norm of A_residual(K) is less than +*> or equal to MAXC2NRMK up to roundoff error. +*> +*> NOTE: An approximation of the null vectors +*> of A can be easily computed from R11(K) +*> and R12(K): +*> +*> Null( A(K) )_approx = P * ( inv(R11(K)) * R12(K) ) +*> ( -I ) +*> +*> \endverbatim +* +*> \par References: +* ================ +*> [1] A Level 3 BLAS QR factorization algorithm with column pivoting developed in 1996. +*> G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain. +*> X. Sun, Computer Science Dept., Duke University, USA. +*> C. H. Bischof, Math. and Comp. Sci. Div., Argonne National Lab, USA. +*> A BLAS-3 version of the QR factorization with column pivoting. +*> LAPACK Working Note 114 +*> \htmlonly +*> https://www.netlib.org/lapack/lawnspdf/lawn114.pdf +*> \endhtmlonly +*> and in +*> SIAM J. Sci. Comput., 19(5):1486-1494, Sept. 1998. +*> \htmlonly +*> https://doi.org/10.1137/S1064827595296732 +*> \endhtmlonly +*> +*> [2] A partial column norm updating strategy developed in 2006. +*> Z. Drmac and Z. Bujanovic, Dept. of Math., University of Zagreb, Croatia. +*> On the failure of rank revealing QR factorization software – a case study. +*> LAPACK Working Note 176. +*> \htmlonly +*> http://www.netlib.org/lapack/lawnspdf/lawn176.pdf +*> \endhtmlonly +*> and in +*> ACM Trans. Math. Softw. 35, 2, Article 12 (July 2008), 28 pages. +*> \htmlonly +*> https://doi.org/10.1145/1377612.1377616 +*> \endhtmlonly +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> November 2023, Igor Kozachenko, James Demmel, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE SGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, A, LDA, + $ K, MAXC2NRMK, RELMAXC2NRMK, JPIV, TAU, + $ WORK, LWORK, IWORK, INFO ) + IMPLICIT NONE +* +* -- LAPACK computational routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER INFO, K, KF, KMAX, LDA, LWORK, M, N, NRHS + REAL ABSTOL, MAXC2NRMK, RELMAXC2NRMK, RELTOL +* .. +* .. Array Arguments .. + INTEGER IWORK( * ), JPIV( * ) + REAL A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER INB, INBMIN, IXOVER + PARAMETER ( INB = 1, INBMIN = 2, IXOVER = 3 ) + REAL ZERO, ONE, TWO + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0, TWO = 2.0E+0 ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY, DONE + INTEGER IINFO, IOFFSET, IWS, J, JB, JBF, JMAXB, JMAX, + $ JMAXC2NRM, KP1, LWKOPT, MINMN, N_SUB, NB, + $ NBMIN, NX + REAL EPS, HUGEVAL, MAXC2NRM, SAFMIN +* .. +* .. External Subroutines .. + EXTERNAL SLAQP2RK, SLAQP3RK, XERBLA +* .. +* .. External Functions .. + LOGICAL SISNAN + INTEGER ISAMAX, ILAENV + REAL SLAMCH, SNRM2 + EXTERNAL SISNAN, SLAMCH, SNRM2, ISAMAX, ILAENV +* .. +* .. Intrinsic Functions .. + INTRINSIC REAL, MAX, MIN +* .. +* .. Executable Statements .. +* +* Test input arguments +* ==================== +* + INFO = 0 + LQUERY = ( LWORK.EQ.-1 ) + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -3 + ELSE IF( KMAX.LT.0 ) THEN + INFO = -4 + ELSE IF( SISNAN( ABSTOL ) ) THEN + INFO = -5 + ELSE IF( SISNAN( RELTOL ) ) THEN + INFO = -6 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -8 + END IF +* +* If the input parameters M, N, NRHS, KMAX, LDA are valid: +* a) Test the input workspace size LWORK for the minimum +* size requirement IWS. +* b) Determine the optimal block size NB and optimal +* workspace size LWKOPT to be returned in WORK(1) +* in case of (1) LWORK < IWS, (2) LQUERY = .TRUE., +* (3) when routine exits. +* Here, IWS is the miminum workspace required for unblocked +* code. +* + IF( INFO.EQ.0 ) THEN + MINMN = MIN( M, N ) + IF( MINMN.EQ.0 ) THEN + IWS = 1 + LWKOPT = 1 + ELSE +* +* Minimal workspace size in case of using only unblocked +* BLAS 2 code in SLAQP2RK. +* 1) SGEQP3RK and SLAQP2RK: 2*N to store full and partial +* column 2-norms. +* 2) SLAQP2RK: N+NRHS-1 to use in WORK array that is used +* in SLARF subroutine inside SLAQP2RK to apply an +* elementary reflector from the left. +* TOTAL_WORK_SIZE = 3*N + NRHS - 1 +* + IWS = 3*N + NRHS - 1 +* +* Assign to NB optimal block size. +* + NB = ILAENV( INB, 'SGEQP3RK', ' ', M, N, -1, -1 ) +* +* A formula for the optimal workspace size in case of using +* both unblocked BLAS 2 in SLAQP2RK and blocked BLAS 3 code +* in SLAQP3RK. +* 1) SGEQP3RK, SLAQP2RK, SLAQP3RK: 2*N to store full and +* partial column 2-norms. +* 2) SLAQP2RK: N+NRHS-1 to use in WORK array that is used +* in SLARF subroutine to apply an elementary reflector +* from the left. +* 3) SLAQP3RK: NB*(N+NRHS) to use in the work array F that +* is used to apply a block reflector from +* the left. +* 4) SLAQP3RK: NB to use in the auxilixary array AUX. +* Sizes (2) and ((3) + (4)) should intersect, therefore +* TOTAL_WORK_SIZE = 2*N + NB*( N+NRHS+1 ), given NBMIN=2. +* + LWKOPT = 2*N + NB*( N+NRHS+1 ) + END IF + WORK( 1 ) = REAL( LWKOPT ) +* + IF( ( LWORK.LT.IWS ) .AND. .NOT.LQUERY ) THEN + INFO = -15 + END IF + END IF +* +* NOTE: The optimal workspace size is returned in WORK(1), if +* the input parameters M, N, NRHS, KMAX, LDA are valid. +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SGEQP3RK', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible for M=0 or N=0. +* + IF( MINMN.EQ.0 ) THEN + K = 0 + MAXC2NRMK = ZERO + RELMAXC2NRMK = ZERO + WORK( 1 ) = REAL( LWKOPT ) + RETURN + END IF +* +* ================================================================== +* +* Initialize column pivot array JPIV. +* + DO J = 1, N + JPIV( J ) = J + END DO +* +* ================================================================== +* +* Initialize storage for partial and exact column 2-norms. +* a) The elements WORK(1:N) are used to store partial column +* 2-norms of the matrix A, and may decrease in each computation +* step; initialize to the values of complete columns 2-norms. +* b) The elements WORK(N+1:2*N) are used to store complete column +* 2-norms of the matrix A, they are not changed during the +* computation; initialize the values of complete columns 2-norms. +* + DO J = 1, N + WORK( J ) = SNRM2( M, A( 1, J ), 1 ) + WORK( N+J ) = WORK( J ) + END DO +* +* ================================================================== +* +* Compute the pivot column index and the maximum column 2-norm +* for the whole original matrix stored in A(1:M,1:N). +* + KP1 = ISAMAX( N, WORK( 1 ), 1 ) + MAXC2NRM = WORK( KP1 ) +* +* ==================================================================. +* + IF( SISNAN( MAXC2NRM ) ) THEN +* +* Check if the matrix A contains NaN, set INFO parameter +* to the column number where the first NaN is found and return +* from the routine. +* + K = 0 + INFO = KP1 +* +* Set MAXC2NRMK and RELMAXC2NRMK to NaN. +* + MAXC2NRMK = MAXC2NRM + RELMAXC2NRMK = MAXC2NRM +* +* Array TAU is not set and contains undefined elements. +* + WORK( 1 ) = REAL( LWKOPT ) + RETURN + END IF +* +* =================================================================== +* + IF( MAXC2NRM.EQ.ZERO ) THEN +* +* Check is the matrix A is a zero matrix, set array TAU and +* return from the routine. +* + K = 0 + MAXC2NRMK = ZERO + RELMAXC2NRMK = ZERO +* + DO J = 1, MINMN + TAU( J ) = ZERO + END DO +* + WORK( 1 ) = REAL( LWKOPT ) + RETURN +* + END IF +* +* =================================================================== +* + HUGEVAL = SLAMCH( 'Overflow' ) +* + IF( MAXC2NRM.GT.HUGEVAL ) THEN +* +* Check if the matrix A contains +Inf or -Inf, set INFO parameter +* to the column number, where the first +/-Inf is found plus N, +* and continue the computation. +* + INFO = N + KP1 +* + END IF +* +* ================================================================== +* +* Quick return if possible for the case when the first +* stopping criterion is satisfied, i.e. KMAX = 0. +* + IF( KMAX.EQ.0 ) THEN + K = 0 + MAXC2NRMK = MAXC2NRM + RELMAXC2NRMK = ONE + DO J = 1, MINMN + TAU( J ) = ZERO + END DO + WORK( 1 ) = REAL( LWKOPT ) + RETURN + END IF +* +* ================================================================== +* + EPS = SLAMCH('Epsilon') +* +* Adjust ABSTOL +* + IF( ABSTOL.GE.ZERO ) THEN + SAFMIN = SLAMCH('Safe minimum') + ABSTOL = MAX( ABSTOL, TWO*SAFMIN ) + END IF +* +* Adjust RELTOL +* + IF( RELTOL.GE.ZERO ) THEN + RELTOL = MAX( RELTOL, EPS ) + END IF +* +* =================================================================== +* +* JMAX is the maximum index of the column to be factorized, +* which is also limited by the first stopping criterion KMAX. +* + JMAX = MIN( KMAX, MINMN ) +* +* =================================================================== +* +* Quick return if possible for the case when the second or third +* stopping criterion for the whole original matrix is satified, +* i.e. MAXC2NRM <= ABSTOL or RELMAXC2NRM <= RELTOL +* (which is ONE <= RELTOL). +* + IF( MAXC2NRM.LE.ABSTOL .OR. ONE.LE.RELTOL ) THEN +* + K = 0 + MAXC2NRMK = MAXC2NRM + RELMAXC2NRMK = ONE +* + DO J = 1, MINMN + TAU( J ) = ZERO + END DO +* + WORK( 1 ) = REAL( LWKOPT ) + RETURN + END IF +* +* ================================================================== +* Factorize columns +* ================================================================== +* +* Determine the block size. +* + NBMIN = 2 + NX = 0 +* + IF( ( NB.GT.1 ) .AND. ( NB.LT.MINMN ) ) THEN +* +* Determine when to cross over from blocked to unblocked code. +* (for N less than NX, unblocked code should be used). +* + NX = MAX( 0, ILAENV( IXOVER, 'SGEQP3RK', ' ', M, N, -1, -1 )) +* + IF( NX.LT.MINMN ) THEN +* +* Determine if workspace is large enough for blocked code. +* + IF( LWORK.LT.LWKOPT ) THEN +* +* Not enough workspace to use optimal block size that +* is currently stored in NB. +* Reduce NB and determine the minimum value of NB. +* + NB = ( LWORK-2*N ) / ( N+1 ) + NBMIN = MAX( 2, ILAENV( INBMIN, 'SGEQP3RK', ' ', M, N, + $ -1, -1 ) ) +* + END IF + END IF + END IF +* +* ================================================================== +* +* DONE is the boolean flag to rerpresent the case when the +* factorization completed in the block factorization routine, +* before the end of the block. +* + DONE = .FALSE. +* +* J is the column index. +* + J = 1 +* +* (1) Use blocked code initially. +* +* JMAXB is the maximum column index of the block, when the +* blocked code is used, is also limited by the first stopping +* criterion KMAX. +* + JMAXB = MIN( KMAX, MINMN - NX ) +* + IF( NB.GE.NBMIN .AND. NB.LT.JMAX .AND. JMAXB.GT.0 ) THEN +* +* Loop over the column blocks of the matrix A(1:M,1:JMAXB). Here: +* J is the column index of a column block; +* JB is the column block size to pass to block factorization +* routine in a loop step; +* JBF is the number of columns that were actually factorized +* that was returned by the block factorization routine +* in a loop step, JBF <= JB; +* N_SUB is the number of columns in the submatrix; +* IOFFSET is the number of rows that should not be factorized. +* + DO WHILE( J.LE.JMAXB ) +* + JB = MIN( NB, JMAXB-J+1 ) + N_SUB = N-J+1 + IOFFSET = J-1 +* +* Factorize JB columns among the columns A(J:N). +* + CALL SLAQP3RK( M, N_SUB, NRHS, IOFFSET, JB, ABSTOL, + $ RELTOL, KP1, MAXC2NRM, A( 1, J ), LDA, + $ DONE, JBF, MAXC2NRMK, RELMAXC2NRMK, + $ JPIV( J ), TAU( J ), + $ WORK( J ), WORK( N+J ), + $ WORK( 2*N+1 ), WORK( 2*N+JB+1 ), + $ N+NRHS-J+1, IWORK, IINFO ) +* +* Set INFO on the first occurence of Inf. +* + IF( IINFO.GT.N_SUB .AND. INFO.EQ.0 ) THEN + INFO = 2*IOFFSET + IINFO + END IF +* + IF( DONE ) THEN +* +* Either the submatrix is zero before the end of the +* column block, or ABSTOL or RELTOL criterion is +* satisfied before the end of the column block, we can +* return from the routine. Perform the following before +* returning: +* a) Set the number of factorized columns K, +* K = IOFFSET + JBF from the last call of blocked +* routine. +* NOTE: 1) MAXC2NRMK and RELMAXC2NRMK are returned +* by the block factorization routine; +* 2) The remaining TAUs are set to ZERO by the +* block factorization routine. +* + K = IOFFSET + JBF +* +* Set INFO on the first occurrence of NaN, NaN takes +* prcedence over Inf. +* + IF( IINFO.LE.N_SUB .AND. IINFO.GT.0 ) THEN + INFO = IOFFSET + IINFO + END IF +* +* Return from the routine. +* + WORK( 1 ) = REAL( LWKOPT ) +* + RETURN +* + END IF +* + J = J + JBF +* + END DO +* + END IF +* +* Use unblocked code to factor the last or only block. +* J = JMAX+1 means we factorized the maximum possible number of +* columns, that is in ELSE clause we need to compute +* the MAXC2NORM and RELMAXC2NORM to return after we processed +* the blocks. +* + IF( J.LE.JMAX ) THEN +* +* N_SUB is the number of columns in the submatrix; +* IOFFSET is the number of rows that should not be factorized. +* + N_SUB = N-J+1 + IOFFSET = J-1 +* + CALL SLAQP2RK( M, N_SUB, NRHS, IOFFSET, JMAX-J+1, + $ ABSTOL, RELTOL, KP1, MAXC2NRM, A( 1, J ), LDA, + $ KF, MAXC2NRMK, RELMAXC2NRMK, JPIV( J ), + $ TAU( J ), WORK( J ), WORK( N+J ), + $ WORK( 2*N+1 ), IINFO ) +* +* ABSTOL or RELTOL criterion is satisfied when the number of +* the factorized columns KF is smaller then the number +* of columns JMAX-J+1 supplied to be factorized by the +* unblocked routine, we can return from +* the routine. Perform the following before returning: +* a) Set the number of factorized columns K, +* b) MAXC2NRMK and RELMAXC2NRMK are returned by the +* unblocked factorization routine above. +* + K = J - 1 + KF +* +* Set INFO on the first exception occurence. +* +* Set INFO on the first exception occurence of Inf or NaN, +* (NaN takes precedence over Inf). +* + IF( IINFO.GT.N_SUB .AND. INFO.EQ.0 ) THEN + INFO = 2*IOFFSET + IINFO + ELSE IF( IINFO.LE.N_SUB .AND. IINFO.GT.0 ) THEN + INFO = IOFFSET + IINFO + END IF +* + ELSE +* +* Compute the return values for blocked code. +* +* Set the number of factorized columns if the unblocked routine +* was not called. +* + K = JMAX +* +* If there exits a residual matrix after the blocked code: +* 1) compute the values of MAXC2NRMK, RELMAXC2NRMK of the +* residual matrix, otherwise set them to ZERO; +* 2) Set TAU(K+1:MINMN) to ZERO. +* + IF( K.LT.MINMN ) THEN + JMAXC2NRM = K + ISAMAX( N-K, WORK( K+1 ), 1 ) + MAXC2NRMK = WORK( JMAXC2NRM ) + IF( K.EQ.0 ) THEN + RELMAXC2NRMK = ONE + ELSE + RELMAXC2NRMK = MAXC2NRMK / MAXC2NRM + END IF +* + DO J = K + 1, MINMN + TAU( J ) = ZERO + END DO +* + END IF +* +* END IF( J.LE.JMAX ) THEN +* + END IF +* + WORK( 1 ) = REAL( LWKOPT ) +* + RETURN +* +* End of SGEQP3RK +* + END diff --git a/lapack-netlib/SRC/slaqp2rk.f b/lapack-netlib/SRC/slaqp2rk.f new file mode 100644 index 000000000..d3dbb3d7c --- /dev/null +++ b/lapack-netlib/SRC/slaqp2rk.f @@ -0,0 +1,713 @@ +*> \brief \b SLAQP2RK computes truncated QR factorization with column pivoting of a real matrix block using Level 2 BLAS and overwrites a real m-by-nrhs matrix B with Q**T * B. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download SLAQP2RK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE SLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, +* $ KP1, MAXC2NRM, A, LDA, K, MAXC2NRMK, +* $ RELMAXC2NRMK, JPIV, TAU, VN1, VN2, WORK, +* $ INFO ) +* IMPLICIT NONE +* +* .. Scalar Arguments .. +* INTEGER INFO, IOFFSET, KP1, K, KMAX, LDA, M, N, NRHS +* REAL ABSTOL, MAXC2NRM, MAXC2NRMK, RELMAXC2NRMK, +* $ RELTOL +* .. +* .. Array Arguments .. +* INTEGER JPIV( * ) +* REAL A( LDA, * ), TAU( * ), VN1( * ), VN2( * ), +* $ WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SLAQP2RK computes a truncated (rank K) or full rank Householder QR +*> factorization with column pivoting of a real matrix +*> block A(IOFFSET+1:M,1:N) as +*> +*> A * P(K) = Q(K) * R(K). +*> +*> The routine uses Level 2 BLAS. The block A(1:IOFFSET,1:N) +*> is accordingly pivoted, but not factorized. +*> +*> The routine also overwrites the right-hand-sides matrix block B +*> stored in A(IOFFSET+1:M,N+1:N+NRHS) with Q(K)**T * B. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of +*> columns of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in] IOFFSET +*> \verbatim +*> IOFFSET is INTEGER +*> The number of rows of the matrix A that must be pivoted +*> but not factorized. IOFFSET >= 0. +*> +*> IOFFSET also represents the number of columns of the whole +*> original matrix A_orig that have been factorized +*> in the previous steps. +*> \endverbatim +*> +*> \param[in] KMAX +*> \verbatim +*> KMAX is INTEGER +*> +*> The first factorization stopping criterion. KMAX >= 0. +*> +*> The maximum number of columns of the matrix A to factorize, +*> i.e. the maximum factorization rank. +*> +*> a) If KMAX >= min(M-IOFFSET,N), then this stopping +*> criterion is not used, factorize columns +*> depending on ABSTOL and RELTOL. +*> +*> b) If KMAX = 0, then this stopping criterion is +*> satisfied on input and the routine exits immediately. +*> This means that the factorization is not performed, +*> the matrices A and B and the arrays TAU, IPIV +*> are not modified. +*> \endverbatim +*> +*> \param[in] ABSTOL +*> \verbatim +*> ABSTOL is DOUBLE PRECISION, cannot be NaN. +*> +*> The second factorization stopping criterion. +*> +*> The absolute tolerance (stopping threshold) for +*> maximum column 2-norm of the residual matrix. +*> The algorithm converges (stops the factorization) when +*> the maximum column 2-norm of the residual matrix +*> is less than or equal to ABSTOL. +*> +*> a) If ABSTOL < 0.0, then this stopping criterion is not +*> used, the routine factorizes columns depending +*> on KMAX and RELTOL. +*> This includes the case ABSTOL = -Inf. +*> +*> b) If 0.0 <= ABSTOL then the input value +*> of ABSTOL is used. +*> \endverbatim +*> +*> \param[in] RELTOL +*> \verbatim +*> RELTOL is DOUBLE PRECISION, cannot be NaN. +*> +*> The third factorization stopping criterion. +*> +*> The tolerance (stopping threshold) for the ratio of the +*> maximum column 2-norm of the residual matrix to the maximum +*> column 2-norm of the original matrix A_orig. The algorithm +*> converges (stops the factorization), when this ratio is +*> less than or equal to RELTOL. +*> +*> a) If RELTOL < 0.0, then this stopping criterion is not +*> used, the routine factorizes columns depending +*> on KMAX and ABSTOL. +*> This includes the case RELTOL = -Inf. +*> +*> d) If 0.0 <= RELTOL then the input value of RELTOL +*> is used. +*> \endverbatim +*> +*> \param[in] KP1 +*> \verbatim +*> KP1 is INTEGER +*> The index of the column with the maximum 2-norm in +*> the whole original matrix A_orig determined in the +*> main routine SGEQP3RK. 1 <= KP1 <= N_orig_mat. +*> \endverbatim +*> +*> \param[in] MAXC2NRM +*> \verbatim +*> MAXC2NRM is DOUBLE PRECISION +*> The maximum column 2-norm of the whole original +*> matrix A_orig computed in the main routine SGEQP3RK. +*> MAXC2NRM >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is REAL array, dimension (LDA,N+NRHS) +*> On entry: +*> the M-by-N matrix A and M-by-NRHS matrix B, as in +*> +*> N NRHS +*> array_A = M [ mat_A, mat_B ] +*> +*> On exit: +*> 1. The elements in block A(IOFFSET+1:M,1:K) below +*> the diagonal together with the array TAU represent +*> the orthogonal matrix Q(K) as a product of elementary +*> reflectors. +*> 2. The upper triangular block of the matrix A stored +*> in A(IOFFSET+1:M,1:K) is the triangular factor obtained. +*> 3. The block of the matrix A stored in A(1:IOFFSET,1:N) +*> has been accordingly pivoted, but not factorized. +*> 4. The rest of the array A, block A(IOFFSET+1:M,K+1:N+NRHS). +*> The left part A(IOFFSET+1:M,K+1:N) of this block +*> contains the residual of the matrix A, and, +*> if NRHS > 0, the right part of the block +*> A(IOFFSET+1:M,N+1:N+NRHS) contains the block of +*> the right-hand-side matrix B. Both these blocks have been +*> updated by multiplication from the left by Q(K)**T. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] K +*> \verbatim +*> K is INTEGER +*> Factorization rank of the matrix A, i.e. the rank of +*> the factor R, which is the same as the number of non-zero +*> rows of the factor R. 0 <= K <= min(M-IOFFSET,KMAX,N). +*> +*> K also represents the number of non-zero Householder +*> vectors. +*> \endverbatim +*> +*> \param[out] MAXC2NRMK +*> \verbatim +*> MAXC2NRMK is DOUBLE PRECISION +*> The maximum column 2-norm of the residual matrix, +*> when the factorization stopped at rank K. MAXC2NRMK >= 0. +*> \endverbatim +*> +*> \param[out] RELMAXC2NRMK +*> \verbatim +*> RELMAXC2NRMK is DOUBLE PRECISION +*> The ratio MAXC2NRMK / MAXC2NRM of the maximum column +*> 2-norm of the residual matrix (when the factorization +*> stopped at rank K) to the maximum column 2-norm of the +*> whole original matrix A. RELMAXC2NRMK >= 0. +*> \endverbatim +*> +*> \param[out] JPIV +*> \verbatim +*> JPIV is INTEGER array, dimension (N) +*> Column pivot indices, for 1 <= j <= N, column j +*> of the matrix A was interchanged with column JPIV(j). +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is REAL array, dimension (min(M-IOFFSET,N)) +*> The scalar factors of the elementary reflectors. +*> \endverbatim +*> +*> \param[in,out] VN1 +*> \verbatim +*> VN1 is REAL array, dimension (N) +*> The vector with the partial column norms. +*> \endverbatim +*> +*> \param[in,out] VN2 +*> \verbatim +*> VN2 is REAL array, dimension (N) +*> The vector with the exact column norms. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is REAL array, dimension (N-1) +*> Used in SLARF subroutine to apply an elementary +*> reflector from the left. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> 1) INFO = 0: successful exit. +*> 2) If INFO = j_1, where 1 <= j_1 <= N, then NaN was +*> detected and the routine stops the computation. +*> The j_1-th column of the matrix A or the j_1-th +*> element of array TAU contains the first occurrence +*> of NaN in the factorization step K+1 ( when K columns +*> have been factorized ). +*> +*> On exit: +*> K is set to the number of +*> factorized columns without +*> exception. +*> MAXC2NRMK is set to NaN. +*> RELMAXC2NRMK is set to NaN. +*> TAU(K+1:min(M,N)) is not set and contains undefined +*> elements. If j_1=K+1, TAU(K+1) +*> may contain NaN. +*> 3) If INFO = j_2, where N+1 <= j_2 <= 2*N, then no NaN +*> was detected, but +Inf (or -Inf) was detected and +*> the routine continues the computation until completion. +*> The (j_2-N)-th column of the matrix A contains the first +*> occurrence of +Inf (or -Inf) in the factorization +*> step K+1 ( when K columns have been factorized ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup laqp2rk +* +*> \par References: +* ================ +*> [1] A Level 3 BLAS QR factorization algorithm with column pivoting developed in 1996. +*> G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain. +*> X. Sun, Computer Science Dept., Duke University, USA. +*> C. H. Bischof, Math. and Comp. Sci. Div., Argonne National Lab, USA. +*> A BLAS-3 version of the QR factorization with column pivoting. +*> LAPACK Working Note 114 +*> \htmlonly +*> https://www.netlib.org/lapack/lawnspdf/lawn114.pdf +*> \endhtmlonly +*> and in +*> SIAM J. Sci. Comput., 19(5):1486-1494, Sept. 1998. +*> \htmlonly +*> https://doi.org/10.1137/S1064827595296732 +*> \endhtmlonly +*> +*> [2] A partial column norm updating strategy developed in 2006. +*> Z. Drmac and Z. Bujanovic, Dept. of Math., University of Zagreb, Croatia. +*> On the failure of rank revealing QR factorization software – a case study. +*> LAPACK Working Note 176. +*> \htmlonly +*> http://www.netlib.org/lapack/lawnspdf/lawn176.pdf +*> \endhtmlonly +*> and in +*> ACM Trans. Math. Softw. 35, 2, Article 12 (July 2008), 28 pages. +*> \htmlonly +*> https://doi.org/10.1145/1377612.1377616 +*> \endhtmlonly +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> November 2023, Igor Kozachenko, James Demmel, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE SLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, + $ KP1, MAXC2NRM, A, LDA, K, MAXC2NRMK, + $ RELMAXC2NRMK, JPIV, TAU, VN1, VN2, WORK, + $ INFO ) + IMPLICIT NONE +* +* -- LAPACK auxiliary routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER INFO, IOFFSET, KP1, K, KMAX, LDA, M, N, NRHS + REAL ABSTOL, MAXC2NRM, MAXC2NRMK, RELMAXC2NRMK, + $ RELTOL +* .. +* .. Array Arguments .. + INTEGER JPIV( * ) + REAL A( LDA, * ), TAU( * ), VN1( * ), VN2( * ), + $ WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) +* .. +* .. Local Scalars .. + INTEGER I, ITEMP, J, JMAXC2NRM, KK, KP, MINMNFACT, + $ MINMNUPDT + REAL AIKK, HUGEVAL, TEMP, TEMP2, TOL3Z +* .. +* .. External Subroutines .. + EXTERNAL SLARF, SLARFG, SSWAP +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, SQRT +* .. +* .. External Functions .. + LOGICAL SISNAN + INTEGER ISAMAX + REAL SLAMCH, SNRM2 + EXTERNAL SISNAN, SLAMCH, ISAMAX, SNRM2 +* .. +* .. Executable Statements .. +* +* Initialize INFO +* + INFO = 0 +* +* MINMNFACT in the smallest dimension of the submatrix +* A(IOFFSET+1:M,1:N) to be factorized. +* +* MINMNUPDT is the smallest dimension +* of the subarray A(IOFFSET+1:M,1:N+NRHS) to be udated, which +* contains the submatrices A(IOFFSET+1:M,1:N) and +* B(IOFFSET+1:M,1:NRHS) as column blocks. +* + MINMNFACT = MIN( M-IOFFSET, N ) + MINMNUPDT = MIN( M-IOFFSET, N+NRHS ) + KMAX = MIN( KMAX, MINMNFACT ) + TOL3Z = SQRT( SLAMCH( 'Epsilon' ) ) + HUGEVAL = SLAMCH( 'Overflow' ) +* +* Compute the factorization, KK is the lomn loop index. +* + DO KK = 1, KMAX +* + I = IOFFSET + KK +* + IF( I.EQ.1 ) THEN +* +* ============================================================ +* +* We are at the first column of the original whole matrix A, +* therefore we use the computed KP1 and MAXC2NRM from the +* main routine. +* + + KP = KP1 +* +* ============================================================ +* + ELSE +* +* ============================================================ +* +* Determine the pivot column in KK-th step, i.e. the index +* of the column with the maximum 2-norm in the +* submatrix A(I:M,K:N). +* + KP = ( KK-1 ) + ISAMAX( N-KK+1, VN1( KK ), 1 ) +* +* Determine the maximum column 2-norm and the relative maximum +* column 2-norm of the submatrix A(I:M,KK:N) in step KK. +* RELMAXC2NRMK will be computed later, after somecondition +* checks on MAXC2NRMK. +* + MAXC2NRMK = VN1( KP ) +* +* ============================================================ +* +* Check if the submatrix A(I:M,KK:N) contains NaN, and set +* INFO parameter to the column number, where the first NaN +* is found and return from the routine. +* We need to check the condition only if the +* column index (same as row index) of the original whole +* matrix is larger than 1, since the condition for whole +* original matrix is checked in the main routine. +* + IF( SISNAN( MAXC2NRMK ) ) THEN +* +* Set K, the number of factorized columns. +* that are not zero. +* + K = KK - 1 + INFO = K + KP +* +* Set RELMAXC2NRMK to NaN. +* + RELMAXC2NRMK = MAXC2NRMK +* +* Array TAU(K+1:MINMNFACT) is not set and contains +* undefined elements. +* + RETURN + END IF +* +* ============================================================ +* +* Quick return, if the submatrix A(I:M,KK:N) is +* a zero matrix. +* We need to check the condition only if the +* column index (same as row index) of the original whole +* matrix is larger than 1, since the condition for whole +* original matrix is checked in the main routine. +* + IF( MAXC2NRMK.EQ.ZERO ) THEN +* +* Set K, the number of factorized columns. +* that are not zero. +* + K = KK - 1 + RELMAXC2NRMK = ZERO +* +* Set TAUs corresponding to the columns that were not +* factorized to ZERO, i.e. set TAU(KK:MINMNFACT) to ZERO. +* + DO J = KK, MINMNFACT + TAU( J ) = ZERO + END DO +* +* Return from the routine. +* + RETURN +* + END IF +* +* ============================================================ +* +* Check if the submatrix A(I:M,KK:N) contains Inf, +* set INFO parameter to the column number, where +* the first Inf is found plus N, and continue +* the computation. +* We need to check the condition only if the +* column index (same as row index) of the original whole +* matrix is larger than 1, since the condition for whole +* original matrix is checked in the main routine. +* + IF( INFO.EQ.0 .AND. MAXC2NRMK.GT.HUGEVAL ) THEN + INFO = N + KK - 1 + KP + END IF +* +* ============================================================ +* +* Test for the second and third stopping criteria. +* NOTE: There is no need to test for ABSTOL >= ZERO, since +* MAXC2NRMK is non-negative. Similarly, there is no need +* to test for RELTOL >= ZERO, since RELMAXC2NRMK is +* non-negative. +* We need to check the condition only if the +* column index (same as row index) of the original whole +* matrix is larger than 1, since the condition for whole +* original matrix is checked in the main routine. + + RELMAXC2NRMK = MAXC2NRMK / MAXC2NRM +* + IF( MAXC2NRMK.LE.ABSTOL .OR. RELMAXC2NRMK.LE.RELTOL ) THEN +* +* Set K, the number of factorized columns. +* + K = KK - 1 +* +* Set TAUs corresponding to the columns that were not +* factorized to ZERO, i.e. set TAU(KK:MINMNFACT) to ZERO. +* + DO J = KK, MINMNFACT + TAU( J ) = ZERO + END DO +* +* Return from the routine. +* + RETURN +* + END IF +* +* ============================================================ +* +* End ELSE of IF(I.EQ.1) +* + END IF +* +* =============================================================== +* +* If the pivot column is not the first column of the +* subblock A(1:M,KK:N): +* 1) swap the KK-th column and the KP-th pivot column +* in A(1:M,1:N); +* 2) copy the KK-th element into the KP-th element of the partial +* and exact 2-norm vectors VN1 and VN2. ( Swap is not needed +* for VN1 and VN2 since we use the element with the index +* larger than KK in the next loop step.) +* 3) Save the pivot interchange with the indices relative to the +* the original matrix A, not the block A(1:M,1:N). +* + IF( KP.NE.KK ) THEN + CALL SSWAP( M, A( 1, KP ), 1, A( 1, KK ), 1 ) + VN1( KP ) = VN1( KK ) + VN2( KP ) = VN2( KK ) + ITEMP = JPIV( KP ) + JPIV( KP ) = JPIV( KK ) + JPIV( KK ) = ITEMP + END IF +* +* Generate elementary reflector H(KK) using the column A(I:M,KK), +* if the column has more than one element, otherwise +* the elementary reflector would be an identity matrix, +* and TAU(KK) = ZERO. +* + IF( I.LT.M ) THEN + CALL SLARFG( M-I+1, A( I, KK ), A( I+1, KK ), 1, + $ TAU( KK ) ) + ELSE + TAU( KK ) = ZERO + END IF +* +* Check if TAU(KK) contains NaN, set INFO parameter +* to the column number where NaN is found and return from +* the routine. +* NOTE: There is no need to check TAU(KK) for Inf, +* since SLARFG cannot produce TAU(KK) or Householder vector +* below the diagonal containing Inf. Only BETA on the diagonal, +* returned by SLARFG can contain Inf, which requires +* TAU(KK) to contain NaN. Therefore, this case of generating Inf +* by SLARFG is covered by checking TAU(KK) for NaN. +* + IF( SISNAN( TAU(KK) ) ) THEN + K = KK - 1 + INFO = KK +* +* Set MAXC2NRMK and RELMAXC2NRMK to NaN. +* + MAXC2NRMK = TAU( KK ) + RELMAXC2NRMK = TAU( KK ) +* +* Array TAU(KK:MINMNFACT) is not set and contains +* undefined elements, except the first element TAU(KK) = NaN. +* + RETURN + END IF +* +* Apply H(KK)**T to A(I:M,KK+1:N+NRHS) from the left. +* ( If M >= N, then at KK = N there is no residual matrix, +* i.e. no columns of A to update, only columns of B. +* If M < N, then at KK = M-IOFFSET, I = M and we have a +* one-row residual matrix in A and the elementary +* reflector is a unit matrix, TAU(KK) = ZERO, i.e. no update +* is needed for the residual matrix in A and the +* right-hand-side-matrix in B. +* Therefore, we update only if +* KK < MINMNUPDT = min(M-IOFFSET, N+NRHS) +* condition is satisfied, not only KK < N+NRHS ) +* + IF( KK.LT.MINMNUPDT ) THEN + AIKK = A( I, KK ) + A( I, KK ) = ONE + CALL SLARF( 'Left', M-I+1, N+NRHS-KK, A( I, KK ), 1, + $ TAU( KK ), A( I, KK+1 ), LDA, WORK( 1 ) ) + A( I, KK ) = AIKK + END IF +* + IF( KK.LT.MINMNFACT ) THEN +* +* Update the partial column 2-norms for the residual matrix, +* only if the residual matrix A(I+1:M,KK+1:N) exists, i.e. +* when KK < min(M-IOFFSET, N). +* + DO J = KK + 1, N + IF( VN1( J ).NE.ZERO ) THEN +* +* NOTE: The following lines follow from the analysis in +* Lapack Working Note 176. +* + TEMP = ONE - ( ABS( A( I, J ) ) / VN1( J ) )**2 + TEMP = MAX( TEMP, ZERO ) + TEMP2 = TEMP*( VN1( J ) / VN2( J ) )**2 + IF( TEMP2 .LE. TOL3Z ) THEN +* +* Compute the column 2-norm for the partial +* column A(I+1:M,J) by explicitly computing it, +* and store it in both partial 2-norm vector VN1 +* and exact column 2-norm vector VN2. +* + VN1( J ) = SNRM2( M-I, A( I+1, J ), 1 ) + VN2( J ) = VN1( J ) +* + ELSE +* +* Update the column 2-norm for the partial +* column A(I+1:M,J) by removing one +* element A(I,J) and store it in partial +* 2-norm vector VN1. +* + VN1( J ) = VN1( J )*SQRT( TEMP ) +* + END IF + END IF + END DO +* + END IF +* +* End factorization loop +* + END DO +* +* If we reached this point, all colunms have been factorized, +* i.e. no condition was triggered to exit the routine. +* Set the number of factorized columns. +* + K = KMAX +* +* We reached the end of the loop, i.e. all KMAX columns were +* factorized, we need to set MAXC2NRMK and RELMAXC2NRMK before +* we return. +* + IF( K.LT.MINMNFACT ) THEN +* + JMAXC2NRM = K + ISAMAX( N-K, VN1( K+1 ), 1 ) + MAXC2NRMK = VN1( JMAXC2NRM ) +* + IF( K.EQ.0 ) THEN + RELMAXC2NRMK = ONE + ELSE + RELMAXC2NRMK = MAXC2NRMK / MAXC2NRM + END IF +* + ELSE + MAXC2NRMK = ZERO + RELMAXC2NRMK = ZERO + END IF +* +* We reached the end of the loop, i.e. all KMAX columns were +* factorized, set TAUs corresponding to the columns that were +* not factorized to ZERO, i.e. TAU(K+1:MINMNFACT) set to ZERO. +* + DO J = K + 1, MINMNFACT + TAU( J ) = ZERO + END DO +* + RETURN +* +* End of SLAQP2RK +* + END diff --git a/lapack-netlib/SRC/slaqp3rk.f b/lapack-netlib/SRC/slaqp3rk.f new file mode 100644 index 000000000..fa735bb9d --- /dev/null +++ b/lapack-netlib/SRC/slaqp3rk.f @@ -0,0 +1,935 @@ +*> \brief \b SLAQP3RK computes a step of truncated QR factorization with column pivoting of a real m-by-n matrix A using Level 3 BLAS and overwrites a real m-by-nrhs matrix B with Q**T * B. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download SLAQP3RK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE SLAQP3RK( M, N, NRHS, IOFFSET, NB, ABSTOL, +* $ RELTOL, KP1, MAXC2NRM, A, LDA, DONE, KB, +* $ MAXC2NRMK, RELMAXC2NRMK, JPIV, TAU, +* $ VN1, VN2, AUXV, F, LDF, IWORK, INFO ) +* IMPLICIT NONE +* LOGICAL DONE +* INTEGER INFO, IOFFSET, KB, KP1, LDA, LDF, M, N, +* $ NB, NRHS +* REAL ABSTOL, MAXC2NRM, MAXC2NRMK, RELMAXC2NRMK, +* $ RELTOL +* +* .. Scalar Arguments .. +* LOGICAL DONE +* INTEGER KB, LDA, LDF, M, N, NB, NRHS, IOFFSET +* REAL ABSTOL, MAXC2NRM, MAXC2NRMK, RELMAXC2NRMK, +* $ RELTOL +* .. +* .. Array Arguments .. +* INTEGER IWORK( * ), JPIV( * ) +* REAL A( LDA, * ), AUXV( * ), F( LDF, * ), TAU( * ), +* $ VN1( * ), VN2( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SLAQP3RK computes a step of truncated QR factorization with column +*> pivoting of a real M-by-N matrix A block A(IOFFSET+1:M,1:N) +*> by using Level 3 BLAS as +*> +*> A * P(KB) = Q(KB) * R(KB). +*> +*> The routine tries to factorize NB columns from A starting from +*> the row IOFFSET+1 and updates the residual matrix with BLAS 3 +*> xGEMM. The number of actually factorized columns is returned +*> is smaller than NB. +*> +*> Block A(1:IOFFSET,1:N) is accordingly pivoted, but not factorized. +*> +*> The routine also overwrites the right-hand-sides B matrix stored +*> in A(IOFFSET+1:M,1:N+1:N+NRHS) with Q(KB)**T * B. +*> +*> Cases when the number of factorized columns KB < NB: +*> +*> (1) In some cases, due to catastrophic cancellations, it cannot +*> factorize all NB columns and need to update the residual matrix. +*> Hence, the actual number of factorized columns in the block returned +*> in KB is smaller than NB. The logical DONE is returned as FALSE. +*> The factorization of the whole original matrix A_orig must proceed +*> with the next block. +*> +*> (2) Whenever the stopping criterion ABSTOL or RELTOL is satisfied, +*> the factorization of the whole original matrix A_orig is stopped, +*> the logical DONE is returned as TRUE. The number of factorized +*> columns which is smaller than NB is returned in KB. +*> +*> (3) In case both stopping criteria ABSTOL or RELTOL are not used, +*> and when the residual matrix is a zero matrix in some factorization +*> step KB, the factorization of the whole original matrix A_orig is +*> stopped, the logical DONE is returned as TRUE. The number of +*> factorized columns which is smaller than NB is returned in KB. +*> +*> (4) Whenever NaN is detected in the matrix A or in the array TAU, +*> the factorization of the whole original matrix A_orig is stopped, +*> the logical DONE is returned as TRUE. The number of factorized +*> columns which is smaller than NB is returned in KB. The INFO +*> parameter is set to the column index of the first NaN occurrence. +*> +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0 +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of +*> columns of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in] IOFFSET +*> \verbatim +*> IOFFSET is INTEGER +*> The number of rows of the matrix A that must be pivoted +*> but not factorized. IOFFSET >= 0. +*> +*> IOFFSET also represents the number of columns of the whole +*> original matrix A_orig that have been factorized +*> in the previous steps. +*> \endverbatim +*> +*> \param[in] NB +*> \verbatim +*> NB is INTEGER +*> Factorization block size, i.e the number of columns +*> to factorize in the matrix A. 0 <= NB +*> +*> If NB = 0, then the routine exits immediately. +*> This means that the factorization is not performed, +*> the matrices A and B and the arrays TAU, IPIV +*> are not modified. +*> \endverbatim +*> +*> \param[in] ABSTOL +*> \verbatim +*> ABSTOL is REAL, cannot be NaN. +*> +*> The absolute tolerance (stopping threshold) for +*> maximum column 2-norm of the residual matrix. +*> The algorithm converges (stops the factorization) when +*> the maximum column 2-norm of the residual matrix +*> is less than or equal to ABSTOL. +*> +*> a) If ABSTOL < 0.0, then this stopping criterion is not +*> used, the routine factorizes columns depending +*> on NB and RELTOL. +*> This includes the case ABSTOL = -Inf. +*> +*> b) If 0.0 <= ABSTOL then the input value +*> of ABSTOL is used. +*> \endverbatim +*> +*> \param[in] RELTOL +*> \verbatim +*> RELTOL is REAL, cannot be NaN. +*> +*> The tolerance (stopping threshold) for the ratio of the +*> maximum column 2-norm of the residual matrix to the maximum +*> column 2-norm of the original matrix A_orig. The algorithm +*> converges (stops the factorization), when this ratio is +*> less than or equal to RELTOL. +*> +*> a) If RELTOL < 0.0, then this stopping criterion is not +*> used, the routine factorizes columns depending +*> on NB and ABSTOL. +*> This includes the case RELTOL = -Inf. +*> +*> d) If 0.0 <= RELTOL then the input value of RELTOL +*> is used. +*> \endverbatim +*> +*> \param[in] KP1 +*> \verbatim +*> KP1 is INTEGER +*> The index of the column with the maximum 2-norm in +*> the whole original matrix A_orig determined in the +*> main routine SGEQP3RK. 1 <= KP1 <= N_orig. +*> \endverbatim +*> +*> \param[in] MAXC2NRM +*> \verbatim +*> MAXC2NRM is REAL +*> The maximum column 2-norm of the whole original +*> matrix A_orig computed in the main routine SGEQP3RK. +*> MAXC2NRM >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is REAL array, dimension (LDA,N+NRHS) +*> On entry: +*> the M-by-N matrix A and M-by-NRHS matrix B, as in +*> +*> N NRHS +*> array_A = M [ mat_A, mat_B ] +*> +*> On exit: +*> 1. The elements in block A(IOFFSET+1:M,1:KB) below +*> the diagonal together with the array TAU represent +*> the orthogonal matrix Q(KB) as a product of elementary +*> reflectors. +*> 2. The upper triangular block of the matrix A stored +*> in A(IOFFSET+1:M,1:KB) is the triangular factor obtained. +*> 3. The block of the matrix A stored in A(1:IOFFSET,1:N) +*> has been accordingly pivoted, but not factorized. +*> 4. The rest of the array A, block A(IOFFSET+1:M,KB+1:N+NRHS). +*> The left part A(IOFFSET+1:M,KB+1:N) of this block +*> contains the residual of the matrix A, and, +*> if NRHS > 0, the right part of the block +*> A(IOFFSET+1:M,N+1:N+NRHS) contains the block of +*> the right-hand-side matrix B. Both these blocks have been +*> updated by multiplication from the left by Q(KB)**T. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] +*> \verbatim +*> DONE is LOGICAL +*> TRUE: a) if the factorization completed before processing +*> all min(M-IOFFSET,NB,N) columns due to ABSTOL +*> or RELTOL criterion, +*> b) if the factorization completed before processing +*> all min(M-IOFFSET,NB,N) columns due to the +*> residual matrix being a ZERO matrix. +*> c) when NaN was detected in the matrix A +*> or in the array TAU. +*> FALSE: otherwise. +*> \endverbatim +*> +*> \param[out] KB +*> \verbatim +*> KB is INTEGER +*> Factorization rank of the matrix A, i.e. the rank of +*> the factor R, which is the same as the number of non-zero +*> rows of the factor R. 0 <= KB <= min(M-IOFFSET,NB,N). +*> +*> KB also represents the number of non-zero Householder +*> vectors. +*> \endverbatim +*> +*> \param[out] MAXC2NRMK +*> \verbatim +*> MAXC2NRMK is REAL +*> The maximum column 2-norm of the residual matrix, +*> when the factorization stopped at rank KB. MAXC2NRMK >= 0. +*> \endverbatim +*> +*> \param[out] RELMAXC2NRMK +*> \verbatim +*> RELMAXC2NRMK is REAL +*> The ratio MAXC2NRMK / MAXC2NRM of the maximum column +*> 2-norm of the residual matrix (when the factorization +*> stopped at rank KB) to the maximum column 2-norm of the +*> original matrix A_orig. RELMAXC2NRMK >= 0. +*> \endverbatim +*> +*> \param[out] JPIV +*> \verbatim +*> JPIV is INTEGER array, dimension (N) +*> Column pivot indices, for 1 <= j <= N, column j +*> of the matrix A was interchanged with column JPIV(j). +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is REAL array, dimension (min(M-IOFFSET,N)) +*> The scalar factors of the elementary reflectors. +*> \endverbatim +*> +*> \param[in,out] VN1 +*> \verbatim +*> VN1 is REAL array, dimension (N) +*> The vector with the partial column norms. +*> \endverbatim +*> +*> \param[in,out] VN2 +*> \verbatim +*> VN2 is REAL array, dimension (N) +*> The vector with the exact column norms. +*> \endverbatim +*> +*> \param[out] AUXV +*> \verbatim +*> AUXV is REAL array, dimension (NB) +*> Auxiliary vector. +*> \endverbatim +*> +*> \param[out] F +*> \verbatim +*> F is REAL array, dimension (LDF,NB) +*> Matrix F**T = L*(Y**T)*A. +*> \endverbatim +*> +*> \param[in] LDF +*> \verbatim +*> LDF is INTEGER +*> The leading dimension of the array F. LDF >= max(1,N+NRHS). +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (N-1). +*> Is a work array. ( IWORK is used to store indices +*> of "bad" columns for norm downdating in the residual +*> matrix ). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> 1) INFO = 0: successful exit. +*> 2) If INFO = j_1, where 1 <= j_1 <= N, then NaN was +*> detected and the routine stops the computation. +*> The j_1-th column of the matrix A or the j_1-th +*> element of array TAU contains the first occurrence +*> of NaN in the factorization step KB+1 ( when KB columns +*> have been factorized ). +*> +*> On exit: +*> KB is set to the number of +*> factorized columns without +*> exception. +*> MAXC2NRMK is set to NaN. +*> RELMAXC2NRMK is set to NaN. +*> TAU(KB+1:min(M,N)) is not set and contains undefined +*> elements. If j_1=KB+1, TAU(KB+1) +*> may contain NaN. +*> 3) If INFO = j_2, where N+1 <= j_2 <= 2*N, then no NaN +*> was detected, but +Inf (or -Inf) was detected and +*> the routine continues the computation until completion. +*> The (j_2-N)-th column of the matrix A contains the first +*> occurrence of +Inf (or -Inf) in the actorization +*> step KB+1 ( when KB columns have been factorized ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup laqp3rk +* +*> \par References: +* ================ +*> [1] A Level 3 BLAS QR factorization algorithm with column pivoting developed in 1996. +*> G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain. +*> X. Sun, Computer Science Dept., Duke University, USA. +*> C. H. Bischof, Math. and Comp. Sci. Div., Argonne National Lab, USA. +*> A BLAS-3 version of the QR factorization with column pivoting. +*> LAPACK Working Note 114 +*> \htmlonly +*> https://www.netlib.org/lapack/lawnspdf/lawn114.pdf +*> \endhtmlonly +*> and in +*> SIAM J. Sci. Comput., 19(5):1486-1494, Sept. 1998. +*> \htmlonly +*> https://doi.org/10.1137/S1064827595296732 +*> \endhtmlonly +*> +*> [2] A partial column norm updating strategy developed in 2006. +*> Z. Drmac and Z. Bujanovic, Dept. of Math., University of Zagreb, Croatia. +*> On the failure of rank revealing QR factorization software – a case study. +*> LAPACK Working Note 176. +*> \htmlonly +*> http://www.netlib.org/lapack/lawnspdf/lawn176.pdf +*> \endhtmlonly +*> and in +*> ACM Trans. Math. Softw. 35, 2, Article 12 (July 2008), 28 pages. +*> \htmlonly +*> https://doi.org/10.1145/1377612.1377616 +*> \endhtmlonly +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> November 2023, Igor Kozachenko, James Demmel, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE SLAQP3RK( M, N, NRHS, IOFFSET, NB, ABSTOL, + $ RELTOL, KP1, MAXC2NRM, A, LDA, DONE, KB, + $ MAXC2NRMK, RELMAXC2NRMK, JPIV, TAU, + $ VN1, VN2, AUXV, F, LDF, IWORK, INFO ) + IMPLICIT NONE +* +* -- LAPACK auxiliary routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + LOGICAL DONE + INTEGER INFO, IOFFSET, KB, KP1, LDA, LDF, M, N, + $ NB, NRHS + REAL ABSTOL, MAXC2NRM, MAXC2NRMK, RELMAXC2NRMK, + $ RELTOL +* .. +* .. Array Arguments .. + INTEGER IWORK( * ), JPIV( * ) + REAL A( LDA, * ), AUXV( * ), F( LDF, * ), TAU( * ), + $ VN1( * ), VN2( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) +* .. +* .. Local Scalars .. + INTEGER ITEMP, J, K, MINMNFACT, MINMNUPDT, + $ LSTICC, KP, I, IF + REAL AIK, HUGEVAL, TEMP, TEMP2, TOL3Z +* .. +* .. External Subroutines .. + EXTERNAL SGEMM, SGEMV, SLARFG, SSWAP +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, SQRT +* .. +* .. External Functions .. + LOGICAL SISNAN + INTEGER ISAMAX + REAL SLAMCH, SNRM2 + EXTERNAL SISNAN, SLAMCH, ISAMAX, SNRM2 +* .. +* .. Executable Statements .. +* +* Initialize INFO +* + INFO = 0 +* +* MINMNFACT in the smallest dimension of the submatrix +* A(IOFFSET+1:M,1:N) to be factorized. +* + MINMNFACT = MIN( M-IOFFSET, N ) + MINMNUPDT = MIN( M-IOFFSET, N+NRHS ) + NB = MIN( NB, MINMNFACT ) + TOL3Z = SQRT( SLAMCH( 'Epsilon' ) ) + HUGEVAL = SLAMCH( 'Overflow' ) +* +* Compute factorization in a while loop over NB columns, +* K is the column index in the block A(1:M,1:N). +* + K = 0 + LSTICC = 0 + DONE = .FALSE. +* + DO WHILE ( K.LT.NB .AND. LSTICC.EQ.0 ) + K = K + 1 + I = IOFFSET + K +* + IF( I.EQ.1 ) THEN +* +* We are at the first column of the original whole matrix A_orig, +* therefore we use the computed KP1 and MAXC2NRM from the +* main routine. +* + KP = KP1 +* + ELSE +* +* Determine the pivot column in K-th step, i.e. the index +* of the column with the maximum 2-norm in the +* submatrix A(I:M,K:N). +* + KP = ( K-1 ) + ISAMAX( N-K+1, VN1( K ), 1 ) +* +* Determine the maximum column 2-norm and the relative maximum +* column 2-norm of the submatrix A(I:M,K:N) in step K. +* + MAXC2NRMK = VN1( KP ) +* +* ============================================================ +* +* Check if the submatrix A(I:M,K:N) contains NaN, set +* INFO parameter to the column number, where the first NaN +* is found and return from the routine. +* We need to check the condition only if the +* column index (same as row index) of the original whole +* matrix is larger than 1, since the condition for whole +* original matrix is checked in the main routine. +* + IF( SISNAN( MAXC2NRMK ) ) THEN +* + DONE = .TRUE. +* +* Set KB, the number of factorized partial columns +* that are non-zero in each step in the block, +* i.e. the rank of the factor R. +* Set IF, the number of processed rows in the block, which +* is the same as the number of processed rows in +* the original whole matrix A_orig. +* + KB = K - 1 + IF = I - 1 + INFO = KB + KP +* +* Set RELMAXC2NRMK to NaN. +* + RELMAXC2NRMK = MAXC2NRMK +* +* There is no need to apply the block reflector to the +* residual of the matrix A stored in A(KB+1:M,KB+1:N), +* since the submatrix contains NaN and we stop +* the computation. +* But, we need to apply the block reflector to the residual +* right hand sides stored in A(KB+1:M,N+1:N+NRHS), if the +* residual right hand sides exist. This occurs +* when ( NRHS != 0 AND KB <= (M-IOFFSET) ): +* +* A(I+1:M,N+1:N+NRHS) := A(I+1:M,N+1:N+NRHS) - +* A(I+1:M,1:KB) * F(N+1:N+NRHS,1:KB)**T. + + IF( NRHS.GT.0 .AND. KB.LT.(M-IOFFSET) ) THEN + CALL SGEMM( 'No transpose', 'Transpose', + $ M-IF, NRHS, KB, -ONE, A( IF+1, 1 ), LDA, + $ F( N+1, 1 ), LDF, ONE, A( IF+1, N+1 ), LDA ) + END IF +* +* There is no need to recompute the 2-norm of the +* difficult columns, since we stop the factorization. +* +* Array TAU(KF+1:MINMNFACT) is not set and contains +* undefined elements. +* +* Return from the routine. +* + RETURN + END IF +* +* Quick return, if the submatrix A(I:M,K:N) is +* a zero matrix. We need to check it only if the column index +* (same as row index) is larger than 1, since the condition +* for the whole original matrix A_orig is checked in the main +* routine. +* + IF( MAXC2NRMK.EQ.ZERO ) THEN +* + DONE = .TRUE. +* +* Set KB, the number of factorized partial columns +* that are non-zero in each step in the block, +* i.e. the rank of the factor R. +* Set IF, the number of processed rows in the block, which +* is the same as the number of processed rows in +* the original whole matrix A_orig. +* + KB = K - 1 + IF = I - 1 + RELMAXC2NRMK = ZERO +* +* There is no need to apply the block reflector to the +* residual of the matrix A stored in A(KB+1:M,KB+1:N), +* since the submatrix is zero and we stop the computation. +* But, we need to apply the block reflector to the residual +* right hand sides stored in A(KB+1:M,N+1:N+NRHS), if the +* residual right hand sides exist. This occurs +* when ( NRHS != 0 AND KB <= (M-IOFFSET) ): +* +* A(I+1:M,N+1:N+NRHS) := A(I+1:M,N+1:N+NRHS) - +* A(I+1:M,1:KB) * F(N+1:N+NRHS,1:KB)**T. +* + IF( NRHS.GT.0 .AND. KB.LT.(M-IOFFSET) ) THEN + CALL SGEMM( 'No transpose', 'Transpose', + $ M-IF, NRHS, KB, -ONE, A( IF+1, 1 ), LDA, + $ F( N+1, 1 ), LDF, ONE, A( IF+1, N+1 ), LDA ) + END IF +* +* There is no need to recompute the 2-norm of the +* difficult columns, since we stop the factorization. +* +* Set TAUs corresponding to the columns that were not +* factorized to ZERO, i.e. set TAU(KB+1:MINMNFACT) = ZERO, +* which is equivalent to seting TAU(K:MINMNFACT) = ZERO. +* + DO J = K, MINMNFACT + TAU( J ) = ZERO + END DO +* +* Return from the routine. +* + RETURN +* + END IF +* +* ============================================================ +* +* Check if the submatrix A(I:M,K:N) contains Inf, +* set INFO parameter to the column number, where +* the first Inf is found plus N, and continue +* the computation. +* We need to check the condition only if the +* column index (same as row index) of the original whole +* matrix is larger than 1, since the condition for whole +* original matrix is checked in the main routine. +* + IF( INFO.EQ.0 .AND. MAXC2NRMK.GT.HUGEVAL ) THEN + INFO = N + K - 1 + KP + END IF +* +* ============================================================ +* +* Test for the second and third tolerance stopping criteria. +* NOTE: There is no need to test for ABSTOL.GE.ZERO, since +* MAXC2NRMK is non-negative. Similarly, there is no need +* to test for RELTOL.GE.ZERO, since RELMAXC2NRMK is +* non-negative. +* We need to check the condition only if the +* column index (same as row index) of the original whole +* matrix is larger than 1, since the condition for whole +* original matrix is checked in the main routine. +* + RELMAXC2NRMK = MAXC2NRMK / MAXC2NRM +* + IF( MAXC2NRMK.LE.ABSTOL .OR. RELMAXC2NRMK.LE.RELTOL ) THEN +* + DONE = .TRUE. +* +* Set KB, the number of factorized partial columns +* that are non-zero in each step in the block, +* i.e. the rank of the factor R. +* Set IF, the number of processed rows in the block, which +* is the same as the number of processed rows in +* the original whole matrix A_orig; +* + KB = K - 1 + IF = I - 1 +* +* Apply the block reflector to the residual of the +* matrix A and the residual of the right hand sides B, if +* the residual matrix and and/or the residual of the right +* hand sides exist, i.e. if the submatrix +* A(I+1:M,KB+1:N+NRHS) exists. This occurs when +* KB < MINMNUPDT = min( M-IOFFSET, N+NRHS ): +* +* A(IF+1:M,K+1:N+NRHS) := A(IF+1:M,KB+1:N+NRHS) - +* A(IF+1:M,1:KB) * F(KB+1:N+NRHS,1:KB)**T. +* + IF( KB.LT.MINMNUPDT ) THEN + CALL SGEMM( 'No transpose', 'Transpose', + $ M-IF, N+NRHS-KB, KB,-ONE, A( IF+1, 1 ), LDA, + $ F( KB+1, 1 ), LDF, ONE, A( IF+1, KB+1 ), LDA ) + END IF +* +* There is no need to recompute the 2-norm of the +* difficult columns, since we stop the factorization. +* +* Set TAUs corresponding to the columns that were not +* factorized to ZERO, i.e. set TAU(KB+1:MINMNFACT) = ZERO, +* which is equivalent to seting TAU(K:MINMNFACT) = ZERO. +* + DO J = K, MINMNFACT + TAU( J ) = ZERO + END DO +* +* Return from the routine. +* + RETURN +* + END IF +* +* ============================================================ +* +* End ELSE of IF(I.EQ.1) +* + END IF +* +* =============================================================== +* +* If the pivot column is not the first column of the +* subblock A(1:M,K:N): +* 1) swap the K-th column and the KP-th pivot column +* in A(1:M,1:N); +* 2) swap the K-th row and the KP-th row in F(1:N,1:K-1) +* 3) copy the K-th element into the KP-th element of the partial +* and exact 2-norm vectors VN1 and VN2. (Swap is not needed +* for VN1 and VN2 since we use the element with the index +* larger than K in the next loop step.) +* 4) Save the pivot interchange with the indices relative to the +* the original matrix A_orig, not the block A(1:M,1:N). +* + IF( KP.NE.K ) THEN + CALL SSWAP( M, A( 1, KP ), 1, A( 1, K ), 1 ) + CALL SSWAP( K-1, F( KP, 1 ), LDF, F( K, 1 ), LDF ) + VN1( KP ) = VN1( K ) + VN2( KP ) = VN2( K ) + ITEMP = JPIV( KP ) + JPIV( KP ) = JPIV( K ) + JPIV( K ) = ITEMP + END IF +* +* Apply previous Householder reflectors to column K: +* A(I:M,K) := A(I:M,K) - A(I:M,1:K-1)*F(K,1:K-1)**T. +* + IF( K.GT.1 ) THEN + CALL SGEMV( 'No transpose', M-I+1, K-1, -ONE, A( I, 1 ), + $ LDA, F( K, 1 ), LDF, ONE, A( I, K ), 1 ) + END IF +* +* Generate elementary reflector H(k) using the column A(I:M,K). +* + IF( I.LT.M ) THEN + CALL SLARFG( M-I+1, A( I, K ), A( I+1, K ), 1, TAU( K ) ) + ELSE + TAU( K ) = ZERO + END IF +* +* Check if TAU(K) contains NaN, set INFO parameter +* to the column number where NaN is found and return from +* the routine. +* NOTE: There is no need to check TAU(K) for Inf, +* since SLARFG cannot produce TAU(K) or Householder vector +* below the diagonal containing Inf. Only BETA on the diagonal, +* returned by SLARFG can contain Inf, which requires +* TAU(K) to contain NaN. Therefore, this case of generating Inf +* by SLARFG is covered by checking TAU(K) for NaN. +* + IF( SISNAN( TAU(K) ) ) THEN +* + DONE = .TRUE. +* +* Set KB, the number of factorized partial columns +* that are non-zero in each step in the block, +* i.e. the rank of the factor R. +* Set IF, the number of processed rows in the block, which +* is the same as the number of processed rows in +* the original whole matrix A_orig. +* + KB = K - 1 + IF = I - 1 + INFO = K +* +* Set MAXC2NRMK and RELMAXC2NRMK to NaN. +* + MAXC2NRMK = TAU( K ) + RELMAXC2NRMK = TAU( K ) +* +* There is no need to apply the block reflector to the +* residual of the matrix A stored in A(KB+1:M,KB+1:N), +* since the submatrix contains NaN and we stop +* the computation. +* But, we need to apply the block reflector to the residual +* right hand sides stored in A(KB+1:M,N+1:N+NRHS), if the +* residual right hand sides exist. This occurs +* when ( NRHS != 0 AND KB <= (M-IOFFSET) ): +* +* A(I+1:M,N+1:N+NRHS) := A(I+1:M,N+1:N+NRHS) - +* A(I+1:M,1:KB) * F(N+1:N+NRHS,1:KB)**T. +* + IF( NRHS.GT.0 .AND. KB.LT.(M-IOFFSET) ) THEN + CALL SGEMM( 'No transpose', 'Transpose', + $ M-IF, NRHS, KB, -ONE, A( IF+1, 1 ), LDA, + $ F( N+1, 1 ), LDF, ONE, A( IF+1, N+1 ), LDA ) + END IF +* +* There is no need to recompute the 2-norm of the +* difficult columns, since we stop the factorization. +* +* Array TAU(KF+1:MINMNFACT) is not set and contains +* undefined elements. +* +* Return from the routine. +* + RETURN + END IF +* +* =============================================================== +* + AIK = A( I, K ) + A( I, K ) = ONE +* +* =============================================================== +* +* Compute the current K-th column of F: +* 1) F(K+1:N,K) := tau(K) * A(I:M,K+1:N)**T * A(I:M,K). +* + IF( K.LT.N+NRHS ) THEN + CALL SGEMV( 'Transpose', M-I+1, N+NRHS-K, + $ TAU( K ), A( I, K+1 ), LDA, A( I, K ), 1, + $ ZERO, F( K+1, K ), 1 ) + END IF +* +* 2) Zero out elements above and on the diagonal of the +* column K in matrix F, i.e elements F(1:K,K). +* + DO J = 1, K + F( J, K ) = ZERO + END DO +* +* 3) Incremental updating of the K-th column of F: +* F(1:N,K) := F(1:N,K) - tau(K) * F(1:N,1:K-1) * A(I:M,1:K-1)**T +* * A(I:M,K). +* + IF( K.GT.1 ) THEN + CALL SGEMV( 'Transpose', M-I+1, K-1, -TAU( K ), + $ A( I, 1 ), LDA, A( I, K ), 1, ZERO, + $ AUXV( 1 ), 1 ) +* + CALL SGEMV( 'No transpose', N+NRHS, K-1, ONE, + $ F( 1, 1 ), LDF, AUXV( 1 ), 1, ONE, + $ F( 1, K ), 1 ) + END IF +* +* =============================================================== +* +* Update the current I-th row of A: +* A(I,K+1:N+NRHS) := A(I,K+1:N+NRHS) +* - A(I,1:K)*F(K+1:N+NRHS,1:K)**T. +* + IF( K.LT.N+NRHS ) THEN + CALL SGEMV( 'No transpose', N+NRHS-K, K, -ONE, + $ F( K+1, 1 ), LDF, A( I, 1 ), LDA, ONE, + $ A( I, K+1 ), LDA ) + END IF +* + A( I, K ) = AIK +* +* Update the partial column 2-norms for the residual matrix, +* only if the residual matrix A(I+1:M,K+1:N) exists, i.e. +* when K < MINMNFACT = min( M-IOFFSET, N ). +* + IF( K.LT.MINMNFACT ) THEN +* + DO J = K + 1, N + IF( VN1( J ).NE.ZERO ) THEN +* +* NOTE: The following lines follow from the analysis in +* Lapack Working Note 176. +* + TEMP = ABS( A( I, J ) ) / VN1( J ) + TEMP = MAX( ZERO, ( ONE+TEMP )*( ONE-TEMP ) ) + TEMP2 = TEMP*( VN1( J ) / VN2( J ) )**2 + IF( TEMP2.LE.TOL3Z ) THEN +* +* At J-index, we have a difficult column for the +* update of the 2-norm. Save the index of the previous +* difficult column in IWORK(J-1). +* NOTE: ILSTCC > 1, threfore we can use IWORK only +* with N-1 elements, where the elements are +* shifted by 1 to the left. +* + IWORK( J-1 ) = LSTICC +* +* Set the index of the last difficult column LSTICC. +* + LSTICC = J +* + ELSE + VN1( J ) = VN1( J )*SQRT( TEMP ) + END IF + END IF + END DO +* + END IF +* +* End of while loop. +* + END DO +* +* Now, afler the loop: +* Set KB, the number of factorized columns in the block; +* Set IF, the number of processed rows in the block, which +* is the same as the number of processed rows in +* the original whole matrix A_orig, IF = IOFFSET + KB. +* + KB = K + IF = I +* +* Apply the block reflector to the residual of the matrix A +* and the residual of the right hand sides B, if the residual +* matrix and and/or the residual of the right hand sides +* exist, i.e. if the submatrix A(I+1:M,KB+1:N+NRHS) exists. +* This occurs when KB < MINMNUPDT = min( M-IOFFSET, N+NRHS ): +* +* A(IF+1:M,K+1:N+NRHS) := A(IF+1:M,KB+1:N+NRHS) - +* A(IF+1:M,1:KB) * F(KB+1:N+NRHS,1:KB)**T. +* + IF( KB.LT.MINMNUPDT ) THEN + CALL SGEMM( 'No transpose', 'Transpose', + $ M-IF, N+NRHS-KB, KB, -ONE, A( IF+1, 1 ), LDA, + $ F( KB+1, 1 ), LDF, ONE, A( IF+1, KB+1 ), LDA ) + END IF +* +* Recompute the 2-norm of the difficult columns. +* Loop over the index of the difficult columns from the largest +* to the smallest index. +* + DO WHILE( LSTICC.GT.0 ) +* +* LSTICC is the index of the last difficult column is greater +* than 1. +* ITEMP is the index of the previous difficult column. +* + ITEMP = IWORK( LSTICC-1 ) +* +* Compute the 2-norm explicilty for the last difficult column and +* save it in the partial and exact 2-norm vectors VN1 and VN2. +* +* NOTE: The computation of VN1( LSTICC ) relies on the fact that +* SNRM2 does not fail on vectors with norm below the value of +* SQRT(SLAMCH('S')) +* + VN1( LSTICC ) = SNRM2( M-IF, A( IF+1, LSTICC ), 1 ) + VN2( LSTICC ) = VN1( LSTICC ) +* +* Downdate the index of the last difficult column to +* the index of the previous difficult column. +* + LSTICC = ITEMP +* + END DO +* + RETURN +* +* End of SLAQP3RK +* + END diff --git a/lapack-netlib/SRC/zgeqp3rk.f b/lapack-netlib/SRC/zgeqp3rk.f new file mode 100644 index 000000000..f8ef986c7 --- /dev/null +++ b/lapack-netlib/SRC/zgeqp3rk.f @@ -0,0 +1,1091 @@ +*> \brief \b ZGEQP3RK computes a truncated Householder QR factorization with column pivoting of a complex m-by-n matrix A by using Level 3 BLAS and overwrites m-by-nrhs matrix B with Q**H * B. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZGEQP3RK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, A, LDA, +* $ K, MAXC2NRMK, RELMAXC2NRMK, JPIV, TAU, +* $ WORK, LWORK, RWORK, IWORK, INFO ) +* IMPLICIT NONE +* +* .. Scalar Arguments .. +* INTEGER INFO, K, KMAX, LDA, LWORK, M, N, NRHS +* DOUBLE PRECISION ABSTOL, MAXC2NRMK, RELMAXC2NRMK, RELTOL +* .. +* .. Array Arguments .. +* INTEGER IWORK( * ), JPIV( * ) +* DOUBLE PRECISION RWORK( * ) +* COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZGEQP3RK performs two tasks simultaneously: +*> +*> Task 1: The routine computes a truncated (rank K) or full rank +*> Householder QR factorization with column pivoting of a complex +*> M-by-N matrix A using Level 3 BLAS. K is the number of columns +*> that were factorized, i.e. factorization rank of the +*> factor R, K <= min(M,N). +*> +*> A * P(K) = Q(K) * R(K) = +*> +*> = Q(K) * ( R11(K) R12(K) ) = Q(K) * ( R(K)_approx ) +*> ( 0 R22(K) ) ( 0 R(K)_residual ), +*> +*> where: +*> +*> P(K) is an N-by-N permutation matrix; +*> Q(K) is an M-by-M orthogonal matrix; +*> R(K)_approx = ( R11(K), R12(K) ) is a rank K approximation of the +*> full rank factor R with K-by-K upper-triangular +*> R11(K) and K-by-N rectangular R12(K). The diagonal +*> entries of R11(K) appear in non-increasing order +*> of absolute value, and absolute values of all of +*> them exceed the maximum column 2-norm of R22(K) +*> up to roundoff error. +*> R(K)_residual = R22(K) is the residual of a rank K approximation +*> of the full rank factor R. It is a +*> an (M-K)-by-(N-K) rectangular matrix; +*> 0 is a an (M-K)-by-K zero matrix. +*> +*> Task 2: At the same time, the routine overwrites a complex M-by-NRHS +*> matrix B with Q(K)**H * B using Level 3 BLAS. +*> +*> ===================================================================== +*> +*> The matrices A and B are stored on input in the array A as +*> the left and right blocks A(1:M,1:N) and A(1:M, N+1:N+NRHS) +*> respectively. +*> +*> N NRHS +*> array_A = M [ mat_A, mat_B ] +*> +*> The truncation criteria (i.e. when to stop the factorization) +*> can be any of the following: +*> +*> 1) The input parameter KMAX, the maximum number of columns +*> KMAX to factorize, i.e. the factorization rank is limited +*> to KMAX. If KMAX >= min(M,N), the criterion is not used. +*> +*> 2) The input parameter ABSTOL, the absolute tolerance for +*> the maximum column 2-norm of the residual matrix R22(K). This +*> means that the factorization stops if this norm is less or +*> equal to ABSTOL. If ABSTOL < 0.0, the criterion is not used. +*> +*> 3) The input parameter RELTOL, the tolerance for the maximum +*> column 2-norm matrix of the residual matrix R22(K) divided +*> by the maximum column 2-norm of the original matrix A, which +*> is equal to abs(R(1,1)). This means that the factorization stops +*> when the ratio of the maximum column 2-norm of R22(K) to +*> the maximum column 2-norm of A is less than or equal to RELTOL. +*> If RELTOL < 0.0, the criterion is not used. +*> +*> 4) In case both stopping criteria ABSTOL or RELTOL are not used, +*> and when the residual matrix R22(K) is a zero matrix in some +*> factorization step K. ( This stopping criterion is implicit. ) +*> +*> The algorithm stops when any of these conditions is first +*> satisfied, otherwise the whole matrix A is factorized. +*> +*> To factorize the whole matrix A, use the values +*> KMAX >= min(M,N), ABSTOL < 0.0 and RELTOL < 0.0. +*> +*> The routine returns: +*> a) Q(K), R(K)_approx = ( R11(K), R12(K) ), +*> R(K)_residual = R22(K), P(K), i.e. the resulting matrices +*> of the factorization; P(K) is represented by JPIV, +*> ( if K = min(M,N), R(K)_approx is the full factor R, +*> and there is no residual matrix R(K)_residual); +*> b) K, the number of columns that were factorized, +*> i.e. factorization rank; +*> c) MAXC2NRMK, the maximum column 2-norm of the residual +*> matrix R(K)_residual = R22(K), +*> ( if K = min(M,N), MAXC2NRMK = 0.0 ); +*> d) RELMAXC2NRMK equals MAXC2NRMK divided by MAXC2NRM, the maximum +*> column 2-norm of the original matrix A, which is equal +*> to abs(R(1,1)), ( if K = min(M,N), RELMAXC2NRMK = 0.0 ); +*> e) Q(K)**H * B, the matrix B with the orthogonal +*> transformation Q(K)**H applied on the left. +*> +*> The N-by-N permutation matrix P(K) is stored in a compact form in +*> the integer array JPIV. For 1 <= j <= N, column j +*> of the matrix A was interchanged with column JPIV(j). +*> +*> The M-by-M orthogonal matrix Q is represented as a product +*> of elementary Householder reflectors +*> +*> Q(K) = H(1) * H(2) * . . . * H(K), +*> +*> where K is the number of columns that were factorized. +*> +*> Each H(j) has the form +*> +*> H(j) = I - tau * v * v**H, +*> +*> where 1 <= j <= K and +*> I is an M-by-M identity matrix, +*> tau is a complex scalar, +*> v is a complex vector with v(1:j-1) = 0 and v(j) = 1. +*> +*> v(j+1:M) is stored on exit in A(j+1:M,j) and tau in TAU(j). +*> +*> See the Further Details section for more information. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e. the number of +*> columns of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in] KMAX +*> \verbatim +*> KMAX is INTEGER +*> +*> The first factorization stopping criterion. KMAX >= 0. +*> +*> The maximum number of columns of the matrix A to factorize, +*> i.e. the maximum factorization rank. +*> +*> a) If KMAX >= min(M,N), then this stopping criterion +*> is not used, the routine factorizes columns +*> depending on ABSTOL and RELTOL. +*> +*> b) If KMAX = 0, then this stopping criterion is +*> satisfied on input and the routine exits immediately. +*> This means that the factorization is not performed, +*> the matrices A and B are not modified, and +*> the matrix A is itself the residual. +*> \endverbatim +*> +*> \param[in] ABSTOL +*> \verbatim +*> ABSTOL is DOUBLE PRECISION +*> +*> The second factorization stopping criterion, cannot be NaN. +*> +*> The absolute tolerance (stopping threshold) for +*> maximum column 2-norm of the residual matrix R22(K). +*> The algorithm converges (stops the factorization) when +*> the maximum column 2-norm of the residual matrix R22(K) +*> is less than or equal to ABSTOL. Let SAFMIN = DLAMCH('S'). +*> +*> a) If ABSTOL is NaN, then no computation is performed +*> and an error message ( INFO = -5 ) is issued +*> by XERBLA. +*> +*> b) If ABSTOL < 0.0, then this stopping criterion is not +*> used, the routine factorizes columns depending +*> on KMAX and RELTOL. +*> This includes the case ABSTOL = -Inf. +*> +*> c) If 0.0 <= ABSTOL < 2*SAFMIN, then ABSTOL = 2*SAFMIN +*> is used. This includes the case ABSTOL = -0.0. +*> +*> d) If 2*SAFMIN <= ABSTOL then the input value +*> of ABSTOL is used. +*> +*> Let MAXC2NRM be the maximum column 2-norm of the +*> whole original matrix A. +*> If ABSTOL chosen above is >= MAXC2NRM, then this +*> stopping criterion is satisfied on input and routine exits +*> immediately after MAXC2NRM is computed. The routine +*> returns MAXC2NRM in MAXC2NORMK, +*> and 1.0 in RELMAXC2NORMK. +*> This includes the case ABSTOL = +Inf. This means that the +*> factorization is not performed, the matrices A and B are not +*> modified, and the matrix A is itself the residual. +*> \endverbatim +*> +*> \param[in] RELTOL +*> \verbatim +*> RELTOL is DOUBLE PRECISION +*> +*> The third factorization stopping criterion, cannot be NaN. +*> +*> The tolerance (stopping threshold) for the ratio +*> abs(R(K+1,K+1))/abs(R(1,1)) of the maximum column 2-norm of +*> the residual matrix R22(K) to the maximum column 2-norm of +*> the original matrix A. The algorithm converges (stops the +*> factorization), when abs(R(K+1,K+1))/abs(R(1,1)) A is less +*> than or equal to RELTOL. Let EPS = DLAMCH('E'). +*> +*> a) If RELTOL is NaN, then no computation is performed +*> and an error message ( INFO = -6 ) is issued +*> by XERBLA. +*> +*> b) If RELTOL < 0.0, then this stopping criterion is not +*> used, the routine factorizes columns depending +*> on KMAX and ABSTOL. +*> This includes the case RELTOL = -Inf. +*> +*> c) If 0.0 <= RELTOL < EPS, then RELTOL = EPS is used. +*> This includes the case RELTOL = -0.0. +*> +*> d) If EPS <= RELTOL then the input value of RELTOL +*> is used. +*> +*> Let MAXC2NRM be the maximum column 2-norm of the +*> whole original matrix A. +*> If RELTOL chosen above is >= 1.0, then this stopping +*> criterion is satisfied on input and routine exits +*> immediately after MAXC2NRM is computed. +*> The routine returns MAXC2NRM in MAXC2NORMK, +*> and 1.0 in RELMAXC2NORMK. +*> This includes the case RELTOL = +Inf. This means that the +*> factorization is not performed, the matrices A and B are not +*> modified, and the matrix A is itself the residual. +*> +*> NOTE: We recommend that RELTOL satisfy +*> min( 10*max(M,N)*EPS, sqrt(EPS) ) <= RELTOL +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N+NRHS) +*> +*> On entry: +*> +*> a) The subarray A(1:M,1:N) contains the M-by-N matrix A. +*> b) The subarray A(1:M,N+1:N+NRHS) contains the M-by-NRHS +*> matrix B. +*> +*> N NRHS +*> array_A = M [ mat_A, mat_B ] +*> +*> On exit: +*> +*> a) The subarray A(1:M,1:N) contains parts of the factors +*> of the matrix A: +*> +*> 1) If K = 0, A(1:M,1:N) contains the original matrix A. +*> 2) If K > 0, A(1:M,1:N) contains parts of the +*> factors: +*> +*> 1. The elements below the diagonal of the subarray +*> A(1:M,1:K) together with TAU(1:K) represent the +*> orthogonal matrix Q(K) as a product of K Householder +*> elementary reflectors. +*> +*> 2. The elements on and above the diagonal of +*> the subarray A(1:K,1:N) contain K-by-N +*> upper-trapezoidal matrix +*> R(K)_approx = ( R11(K), R12(K) ). +*> NOTE: If K=min(M,N), i.e. full rank factorization, +*> then R_approx(K) is the full factor R which +*> is upper-trapezoidal. If, in addition, M>=N, +*> then R is upper-triangular. +*> +*> 3. The subarray A(K+1:M,K+1:N) contains (M-K)-by-(N-K) +*> rectangular matrix R(K)_residual = R22(K). +*> +*> b) If NRHS > 0, the subarray A(1:M,N+1:N+NRHS) contains +*> the M-by-NRHS product Q(K)**H * B. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> This is the leading dimension for both matrices, A and B. +*> \endverbatim +*> +*> \param[out] K +*> \verbatim +*> K is INTEGER +*> Factorization rank of the matrix A, i.e. the rank of +*> the factor R, which is the same as the number of non-zero +*> rows of the factor R. 0 <= K <= min(M,KMAX,N). +*> +*> K also represents the number of non-zero Householder +*> vectors. +*> +*> NOTE: If K = 0, a) the arrays A and B are not modified; +*> b) the array TAU(1:min(M,N)) is set to ZERO, +*> if the matrix A does not contain NaN, +*> otherwise the elements TAU(1:min(M,N)) +*> are undefined; +*> c) the elements of the array JPIV are set +*> as follows: for j = 1:N, JPIV(j) = j. +*> \endverbatim +*> +*> \param[out] MAXC2NRMK +*> \verbatim +*> MAXC2NRMK is DOUBLE PRECISION +*> The maximum column 2-norm of the residual matrix R22(K), +*> when the factorization stopped at rank K. MAXC2NRMK >= 0. +*> +*> a) If K = 0, i.e. the factorization was not performed, +*> the matrix A was not modified and is itself a residual +*> matrix, then MAXC2NRMK equals the maximum column 2-norm +*> of the original matrix A. +*> +*> b) If 0 < K < min(M,N), then MAXC2NRMK is returned. +*> +*> c) If K = min(M,N), i.e. the whole matrix A was +*> factorized and there is no residual matrix, +*> then MAXC2NRMK = 0.0. +*> +*> NOTE: MAXC2NRMK in the factorization step K would equal +*> R(K+1,K+1) in the next factorization step K+1. +*> \endverbatim +*> +*> \param[out] RELMAXC2NRMK +*> \verbatim +*> RELMAXC2NRMK is DOUBLE PRECISION +*> The ratio MAXC2NRMK / MAXC2NRM of the maximum column +*> 2-norm of the residual matrix R22(K) (when the factorization +*> stopped at rank K) to the maximum column 2-norm of the +*> whole original matrix A. RELMAXC2NRMK >= 0. +*> +*> a) If K = 0, i.e. the factorization was not performed, +*> the matrix A was not modified and is itself a residual +*> matrix, then RELMAXC2NRMK = 1.0. +*> +*> b) If 0 < K < min(M,N), then +*> RELMAXC2NRMK = MAXC2NRMK / MAXC2NRM is returned. +*> +*> c) If K = min(M,N), i.e. the whole matrix A was +*> factorized and there is no residual matrix, +*> then RELMAXC2NRMK = 0.0. +*> +*> NOTE: RELMAXC2NRMK in the factorization step K would equal +*> abs(R(K+1,K+1))/abs(R(1,1)) in the next factorization +*> step K+1. +*> \endverbatim +*> +*> \param[out] JPIV +*> \verbatim +*> JPIV is INTEGER array, dimension (N) +*> Column pivot indices. For 1 <= j <= N, column j +*> of the matrix A was interchanged with column JPIV(j). +*> +*> The elements of the array JPIV(1:N) are always set +*> by the routine, for example, even when no columns +*> were factorized, i.e. when K = 0, the elements are +*> set as JPIV(j) = j for j = 1:N. +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is COMPLEX*16 array, dimension (min(M,N)) +*> The scalar factors of the elementary reflectors. +*> +*> If 0 < K <= min(M,N), only the elements TAU(1:K) of +*> the array TAU are modified by the factorization. +*> After the factorization computed, if no NaN was found +*> during the factorization, the remaining elements +*> TAU(K+1:min(M,N)) are set to zero, otherwise the +*> elements TAU(K+1:min(M,N)) are not set and therefore +*> undefined. +*> ( If K = 0, all elements of TAU are set to zero, if +*> the matrix A does not contain NaN. ) +*> \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 dimension of the array WORK. +*. LWORK >= N+NRHS-1 +*> For optimal performance LWORK >= NB*( N+NRHS+1 ), +*> where NB is the optimal block size for ZGEQP3RK returned +*> by ILAENV. Minimal block size MINNB=2. +*> +*> NOTE: The decision, whether to use unblocked BLAS 2 +*> or blocked BLAS 3 code is based not only on the dimension +*> LWORK of the availbale workspace WORK, but also also on the +*> matrix A dimension N via crossover point NX returned +*> by ILAENV. (For N less than NX, unblocked code should be +*> used.) +*> +*> 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] RWORK +*> \verbatim +*> RWORK is DOUBLE PRECISION array, dimension (2*N) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (N-1). +*> Is a work array. ( IWORK is used to store indices +*> of "bad" columns for norm downdating in the residual +*> matrix in the blocked step auxiliary subroutine ZLAQP3RK ). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> 1) INFO = 0: successful exit. +*> 2) INFO < 0: if INFO = -i, the i-th argument had an +*> illegal value. +*> 3) If INFO = j_1, where 1 <= j_1 <= N, then NaN was +*> detected and the routine stops the computation. +*> The j_1-th column of the matrix A or the j_1-th +*> element of array TAU contains the first occurrence +*> of NaN in the factorization step K+1 ( when K columns +*> have been factorized ). +*> +*> On exit: +*> K is set to the number of +*> factorized columns without +*> exception. +*> MAXC2NRMK is set to NaN. +*> RELMAXC2NRMK is set to NaN. +*> TAU(K+1:min(M,N)) is not set and contains undefined +*> elements. If j_1=K+1, TAU(K+1) +*> may contain NaN. +*> 4) If INFO = j_2, where N+1 <= j_2 <= 2*N, then no NaN +*> was detected, but +Inf (or -Inf) was detected and +*> the routine continues the computation until completion. +*> The (j_2-N)-th column of the matrix A contains the first +*> occurrence of +Inf (or -Inf) in the factorization +*> step K+1 ( when K columns have been factorized ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup geqp3rk +* +*> \par Further Details: +* ===================== +* +*> \verbatim +*> ZGEQP3RK is based on the same BLAS3 Householder QR factorization +*> algorithm with column pivoting as in ZGEQP3 routine which uses +*> ZLARFG routine to generate Householder reflectors +*> for QR factorization. +*> +*> We can also write: +*> +*> A = A_approx(K) + A_residual(K) +*> +*> The low rank approximation matrix A(K)_approx from +*> the truncated QR factorization of rank K of the matrix A is: +*> +*> A(K)_approx = Q(K) * ( R(K)_approx ) * P(K)**T +*> ( 0 0 ) +*> +*> = Q(K) * ( R11(K) R12(K) ) * P(K)**T +*> ( 0 0 ) +*> +*> The residual A_residual(K) of the matrix A is: +*> +*> A_residual(K) = Q(K) * ( 0 0 ) * P(K)**T = +*> ( 0 R(K)_residual ) +*> +*> = Q(K) * ( 0 0 ) * P(K)**T +*> ( 0 R22(K) ) +*> +*> The truncated (rank K) factorization guarantees that +*> the maximum column 2-norm of A_residual(K) is less than +*> or equal to MAXC2NRMK up to roundoff error. +*> +*> NOTE: An approximation of the null vectors +*> of A can be easily computed from R11(K) +*> and R12(K): +*> +*> Null( A(K) )_approx = P * ( inv(R11(K)) * R12(K) ) +*> ( -I ) +*> +*> \endverbatim +* +*> \par References: +* ================ +*> [1] A Level 3 BLAS QR factorization algorithm with column pivoting developed in 1996. +*> G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain. +*> X. Sun, Computer Science Dept., Duke University, USA. +*> C. H. Bischof, Math. and Comp. Sci. Div., Argonne National Lab, USA. +*> A BLAS-3 version of the QR factorization with column pivoting. +*> LAPACK Working Note 114 +*> \htmlonly +*> https://www.netlib.org/lapack/lawnspdf/lawn114.pdf +*> \endhtmlonly +*> and in +*> SIAM J. Sci. Comput., 19(5):1486-1494, Sept. 1998. +*> \htmlonly +*> https://doi.org/10.1137/S1064827595296732 +*> \endhtmlonly +*> +*> [2] A partial column norm updating strategy developed in 2006. +*> Z. Drmac and Z. Bujanovic, Dept. of Math., University of Zagreb, Croatia. +*> On the failure of rank revealing QR factorization software – a case study. +*> LAPACK Working Note 176. +*> \htmlonly +*> http://www.netlib.org/lapack/lawnspdf/lawn176.pdf +*> \endhtmlonly +*> and in +*> ACM Trans. Math. Softw. 35, 2, Article 12 (July 2008), 28 pages. +*> \htmlonly +*> https://doi.org/10.1145/1377612.1377616 +*> \endhtmlonly +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> November 2023, Igor Kozachenko, James Demmel, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE ZGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, A, LDA, + $ K, MAXC2NRMK, RELMAXC2NRMK, JPIV, TAU, + $ WORK, LWORK, RWORK, IWORK, INFO ) + IMPLICIT NONE +* +* -- LAPACK computational routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER INFO, K, KF, KMAX, LDA, LWORK, M, N, NRHS + DOUBLE PRECISION ABSTOL, MAXC2NRMK, RELMAXC2NRMK, RELTOL +* .. +* .. Array Arguments .. + INTEGER IWORK( * ), JPIV( * ) + DOUBLE PRECISION RWORK( * ) + COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER INB, INBMIN, IXOVER + PARAMETER ( INB = 1, INBMIN = 2, IXOVER = 3 ) + DOUBLE PRECISION ZERO, ONE, TWO + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 ) + COMPLEX*16 CZERO + PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY, DONE + INTEGER IINFO, IOFFSET, IWS, J, JB, JBF, JMAXB, JMAX, + $ JMAXC2NRM, KP1, LWKOPT, MINMN, N_SUB, NB, + $ NBMIN, NX + DOUBLE PRECISION EPS, HUGEVAL, MAXC2NRM, SAFMIN +* .. +* .. External Subroutines .. + EXTERNAL ZLAQP2RK, ZLAQP3RK, XERBLA +* .. +* .. External Functions .. + LOGICAL DISNAN + INTEGER IDAMAX, ILAENV + DOUBLE PRECISION DLAMCH, DZNRM2 + EXTERNAL DISNAN, DLAMCH, DZNRM2, IDAMAX, ILAENV +* .. +* .. Intrinsic Functions .. + INTRINSIC DCMPLX, MAX, MIN +* .. +* .. Executable Statements .. +* +* Test input arguments +* ==================== +* + INFO = 0 + LQUERY = ( LWORK.EQ.-1 ) + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -3 + ELSE IF( KMAX.LT.0 ) THEN + INFO = -4 + ELSE IF( DISNAN( ABSTOL ) ) THEN + INFO = -5 + ELSE IF( DISNAN( RELTOL ) ) THEN + INFO = -6 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -8 + END IF +* +* If the input parameters M, N, NRHS, KMAX, LDA are valid: +* a) Test the input workspace size LWORK for the minimum +* size requirement IWS. +* b) Determine the optimal block size NB and optimal +* workspace size LWKOPT to be returned in WORK(1) +* in case of (1) LWORK < IWS, (2) LQUERY = .TRUE., +* (3) when routine exits. +* Here, IWS is the miminum workspace required for unblocked +* code. +* + IF( INFO.EQ.0 ) THEN + MINMN = MIN( M, N ) + IF( MINMN.EQ.0 ) THEN + IWS = 1 + LWKOPT = 1 + ELSE +* +* Minimal workspace size in case of using only unblocked +* BLAS 2 code in ZLAQP2RK. +* 1) ZLAQP2RK: N+NRHS-1 to use in WORK array that is used +* in ZLARF subroutine inside ZLAQP2RK to apply an +* elementary reflector from the left. +* TOTAL_WORK_SIZE = 3*N + NRHS - 1 +* + IWS = N + NRHS - 1 +* +* Assign to NB optimal block size. +* + NB = ILAENV( INB, 'ZGEQP3RK', ' ', M, N, -1, -1 ) +* +* A formula for the optimal workspace size in case of using +* both unblocked BLAS 2 in ZLAQP2RK and blocked BLAS 3 code +* in ZLAQP3RK. +* 1) ZGEQP3RK, ZLAQP2RK, ZLAQP3RK: 2*N to store full and +* partial column 2-norms. +* 2) ZLAQP2RK: N+NRHS-1 to use in WORK array that is used +* in ZLARF subroutine to apply an elementary reflector +* from the left. +* 3) ZLAQP3RK: NB*(N+NRHS) to use in the work array F that +* is used to apply a block reflector from +* the left. +* 4) ZLAQP3RK: NB to use in the auxilixary array AUX. +* Sizes (2) and ((3) + (4)) should intersect, therefore +* TOTAL_WORK_SIZE = 2*N + NB*( N+NRHS+1 ), given NBMIN=2. +* + LWKOPT = 2*N + NB*( N+NRHS+1 ) + END IF + WORK( 1 ) = DCMPLX( LWKOPT ) +* + IF( ( LWORK.LT.IWS ) .AND. .NOT.LQUERY ) THEN + INFO = -15 + END IF + END IF +* +* NOTE: The optimal workspace size is returned in WORK(1), if +* the input parameters M, N, NRHS, KMAX, LDA are valid. +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZGEQP3RK', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible for M=0 or N=0. +* + IF( MINMN.EQ.0 ) THEN + K = 0 + MAXC2NRMK = ZERO + RELMAXC2NRMK = ZERO + WORK( 1 ) = DCMPLX( LWKOPT ) + RETURN + END IF +* +* ================================================================== +* +* Initialize column pivot array JPIV. +* + DO J = 1, N + JPIV( J ) = J + END DO +* +* ================================================================== +* +* Initialize storage for partial and exact column 2-norms. +* a) The elements WORK(1:N) are used to store partial column +* 2-norms of the matrix A, and may decrease in each computation +* step; initialize to the values of complete columns 2-norms. +* b) The elements WORK(N+1:2*N) are used to store complete column +* 2-norms of the matrix A, they are not changed during the +* computation; initialize the values of complete columns 2-norms. +* + DO J = 1, N + RWORK( J ) = DZNRM2( M, A( 1, J ), 1 ) + RWORK( N+J ) = RWORK( J ) + END DO +* +* ================================================================== +* +* Compute the pivot column index and the maximum column 2-norm +* for the whole original matrix stored in A(1:M,1:N). +* + KP1 = IDAMAX( N, RWORK( 1 ), 1 ) +* +* ==================================================================. +* + IF( DISNAN( MAXC2NRM ) ) THEN +* +* Check if the matrix A contains NaN, set INFO parameter +* to the column number where the first NaN is found and return +* from the routine. +* + K = 0 + INFO = KP1 +* +* Set MAXC2NRMK and RELMAXC2NRMK to NaN. +* + MAXC2NRMK = MAXC2NRM + RELMAXC2NRMK = MAXC2NRM +* +* Array TAU is not set and contains undefined elements. +* + WORK( 1 ) = DCMPLX( LWKOPT ) + RETURN + END IF +* +* =================================================================== +* + IF( MAXC2NRM.EQ.ZERO ) THEN +* +* Check is the matrix A is a zero matrix, set array TAU and +* return from the routine. +* + K = 0 + MAXC2NRMK = ZERO + RELMAXC2NRMK = ZERO +* + DO J = 1, MINMN + TAU( J ) = CZERO + END DO +* + WORK( 1 ) = DCMPLX( LWKOPT ) + RETURN +* + END IF +* +* =================================================================== +* + HUGEVAL = DLAMCH( 'Overflow' ) +* + IF( MAXC2NRM.GT.HUGEVAL ) THEN +* +* Check if the matrix A contains +Inf or -Inf, set INFO parameter +* to the column number, where the first +/-Inf is found plus N, +* and continue the computation. +* + INFO = N + KP1 +* + END IF +* +* ================================================================== +* +* Quick return if possible for the case when the first +* stopping criterion is satisfied, i.e. KMAX = 0. +* + IF( KMAX.EQ.0 ) THEN + K = 0 + MAXC2NRMK = MAXC2NRM + RELMAXC2NRMK = ONE + DO J = 1, MINMN + TAU( J ) = CZERO + END DO + WORK( 1 ) = DCMPLX( LWKOPT ) + RETURN + END IF +* +* ================================================================== +* + EPS = DLAMCH('Epsilon') +* +* Adjust ABSTOL +* + IF( ABSTOL.GE.ZERO ) THEN + SAFMIN = DLAMCH('Safe minimum') + ABSTOL = MAX( ABSTOL, TWO*SAFMIN ) + END IF +* +* Adjust RELTOL +* + IF( RELTOL.GE.ZERO ) THEN + RELTOL = MAX( RELTOL, EPS ) + END IF +* +* =================================================================== +* +* JMAX is the maximum index of the column to be factorized, +* which is also limited by the first stopping criterion KMAX. +* + JMAX = MIN( KMAX, MINMN ) +* +* =================================================================== +* +* Quick return if possible for the case when the second or third +* stopping criterion for the whole original matrix is satified, +* i.e. MAXC2NRM <= ABSTOL or RELMAXC2NRM <= RELTOL +* (which is ONE <= RELTOL). +* + IF( MAXC2NRM.LE.ABSTOL .OR. ONE.LE.RELTOL ) THEN +* + K = 0 + MAXC2NRMK = MAXC2NRM + RELMAXC2NRMK = ONE +* + DO J = 1, MINMN + TAU( J ) = CZERO + END DO +* + WORK( 1 ) = DCMPLX( LWKOPT ) + RETURN + END IF +* +* ================================================================== +* Factorize columns +* ================================================================== +* +* Determine the block size. +* + NBMIN = 2 + NX = 0 +* + IF( ( NB.GT.1 ) .AND. ( NB.LT.MINMN ) ) THEN +* +* Determine when to cross over from blocked to unblocked code. +* (for N less than NX, unblocked code should be used). +* + NX = MAX( 0, ILAENV( IXOVER, 'ZGEQP3RK', ' ', M, N, -1, -1 ) ) +* + IF( NX.LT.MINMN ) THEN +* +* Determine if workspace is large enough for blocked code. +* + IF( LWORK.LT.LWKOPT ) THEN +* +* Not enough workspace to use optimal block size that +* is currently stored in NB. +* Reduce NB and determine the minimum value of NB. +* + NB = ( LWORK-2*N ) / ( N+1 ) + NBMIN = MAX( 2, ILAENV( INBMIN, 'ZGEQP3RK', ' ', M, N, + $ -1, -1 ) ) +* + END IF + END IF + END IF +* +* ================================================================== +* +* DONE is the boolean flag to rerpresent the case when the +* factorization completed in the block factorization routine, +* before the end of the block. +* + DONE = .FALSE. +* +* J is the column index. +* + J = 1 +* +* (1) Use blocked code initially. +* +* JMAXB is the maximum column index of the block, when the +* blocked code is used, is also limited by the first stopping +* criterion KMAX. +* + JMAXB = MIN( KMAX, MINMN - NX ) +* + IF( NB.GE.NBMIN .AND. NB.LT.JMAX .AND. JMAXB.GT.0 ) THEN +* +* Loop over the column blocks of the matrix A(1:M,1:JMAXB). Here: +* J is the column index of a column block; +* JB is the column block size to pass to block factorization +* routine in a loop step; +* JBF is the number of columns that were actually factorized +* that was returned by the block factorization routine +* in a loop step, JBF <= JB; +* N_SUB is the number of columns in the submatrix; +* IOFFSET is the number of rows that should not be factorized. +* + DO WHILE( J.LE.JMAXB ) +* + JB = MIN( NB, JMAXB-J+1 ) + N_SUB = N-J+1 + IOFFSET = J-1 +* +* Factorize JB columns among the columns A(J:N). +* + CALL ZLAQP3RK( M, N_SUB, NRHS, IOFFSET, JB, ABSTOL, + $ RELTOL, KP1, MAXC2NRM, A( 1, J ), LDA, + $ DONE, JBF, MAXC2NRMK, RELMAXC2NRMK, + $ JPIV( J ), TAU( J ), + $ RWORK( J ), RWORK( N+J ), + $ WORK( 1 ), WORK( JB+1 ), + $ N+NRHS-J+1, IWORK, IINFO ) +* +* Set INFO on the first occurence of Inf. +* + IF( IINFO.GT.N_SUB .AND. INFO.EQ.0 ) THEN + INFO = 2*IOFFSET + IINFO + END IF +* + IF( DONE ) THEN +* +* Either the submatrix is zero before the end of the +* column block, or ABSTOL or RELTOL criterion is +* satisfied before the end of the column block, we can +* return from the routine. Perform the following before +* returning: +* a) Set the number of factorized columns K, +* K = IOFFSET + JBF from the last call of blocked +* routine. +* NOTE: 1) MAXC2NRMK and RELMAXC2NRMK are returned +* by the block factorization routine; +* 2) The remaining TAUs are set to ZERO by the +* block factorization routine. +* + K = IOFFSET + JBF +* +* Set INFO on the first occurrence of NaN, NaN takes +* prcedence over Inf. +* + IF( IINFO.LE.N_SUB .AND. IINFO.GT.0 ) THEN + INFO = IOFFSET + IINFO + END IF +* +* Return from the routine. +* + WORK( 1 ) = DCMPLX( LWKOPT ) +* + RETURN +* + END IF +* + J = J + JBF +* + END DO +* + END IF +* +* Use unblocked code to factor the last or only block. +* J = JMAX+1 means we factorized the maximum possible number of +* columns, that is in ELSE clause we need to compute +* the MAXC2NORM and RELMAXC2NORM to return after we processed +* the blocks. +* + IF( J.LE.JMAX ) THEN +* +* N_SUB is the number of columns in the submatrix; +* IOFFSET is the number of rows that should not be factorized. +* + N_SUB = N-J+1 + IOFFSET = J-1 +* + CALL ZLAQP2RK( M, N_SUB, NRHS, IOFFSET, JMAX-J+1, + $ ABSTOL, RELTOL, KP1, MAXC2NRM, A( 1, J ), LDA, + $ KF, MAXC2NRMK, RELMAXC2NRMK, JPIV( J ), + $ TAU( J ), RWORK( J ), RWORK( N+J ), + $ WORK( 1 ), IINFO ) +* +* ABSTOL or RELTOL criterion is satisfied when the number of +* the factorized columns KF is smaller then the number +* of columns JMAX-J+1 supplied to be factorized by the +* unblocked routine, we can return from +* the routine. Perform the following before returning: +* a) Set the number of factorized columns K, +* b) MAXC2NRMK and RELMAXC2NRMK are returned by the +* unblocked factorization routine above. +* + K = J - 1 + KF +* +* Set INFO on the first exception occurence. +* +* Set INFO on the first exception occurence of Inf or NaN, +* (NaN takes precedence over Inf). +* + IF( IINFO.GT.N_SUB .AND. INFO.EQ.0 ) THEN + INFO = 2*IOFFSET + IINFO + ELSE IF( IINFO.LE.N_SUB .AND. IINFO.GT.0 ) THEN + INFO = IOFFSET + IINFO + END IF +* + ELSE +* +* Compute the return values for blocked code. +* +* Set the number of factorized columns if the unblocked routine +* was not called. +* + K = JMAX +* +* If there exits a residual matrix after the blocked code: +* 1) compute the values of MAXC2NRMK, RELMAXC2NRMK of the +* residual matrix, otherwise set them to ZERO; +* 2) Set TAU(K+1:MINMN) to ZERO. +* + IF( K.LT.MINMN ) THEN + JMAXC2NRM = K + IDAMAX( N-K, RWORK( K+1 ), 1 ) + MAXC2NRMK = RWORK( JMAXC2NRM ) + IF( K.EQ.0 ) THEN + RELMAXC2NRMK = ONE + ELSE + RELMAXC2NRMK = MAXC2NRMK / MAXC2NRM + END IF +* + DO J = K + 1, MINMN + TAU( J ) = CZERO + END DO +* + ELSE + MAXC2NRMK = ZERO + RELMAXC2NRMK = ZERO +* + END IF +* +* END IF( J.LE.JMAX ) THEN +* + END IF +* + WORK( 1 ) = DCMPLX( LWKOPT ) +* + RETURN +* +* End of ZGEQP3RK +* + END diff --git a/lapack-netlib/SRC/zlaqp2rk.f b/lapack-netlib/SRC/zlaqp2rk.f new file mode 100644 index 000000000..f1e9f4899 --- /dev/null +++ b/lapack-netlib/SRC/zlaqp2rk.f @@ -0,0 +1,726 @@ +*> \brief \b ZLAQP2RK computes truncated QR factorization with column pivoting of a complex matrix block using Level 2 BLAS and overwrites a complex m-by-nrhs matrix B with Q**H * B. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZLAQP2RK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, +* $ KP1, MAXC2NRM, A, LDA, K, MAXC2NRMK, +* $ RELMAXC2NRMK, JPIV, TAU, VN1, VN2, WORK, +* $ INFO ) +* IMPLICIT NONE +* +* .. Scalar Arguments .. +* INTEGER INFO, IOFFSET, KP1, K, KMAX, LDA, M, N, NRHS +* DOUBLE PRECISION ABSTOL, MAXC2NRM, MAXC2NRMK, RELMAXC2NRMK, +* $ RELTOL +* .. +* .. Array Arguments .. +* INTEGER JPIV( * ) +* DOUBLE PRECISION VN1( * ), VN2( * ) +* COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) +* $ +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZLAQP2RK computes a truncated (rank K) or full rank Householder QR +*> factorization with column pivoting of the complex matrix +*> block A(IOFFSET+1:M,1:N) as +*> +*> A * P(K) = Q(K) * R(K). +*> +*> The routine uses Level 2 BLAS. The block A(1:IOFFSET,1:N) +*> is accordingly pivoted, but not factorized. +*> +*> The routine also overwrites the right-hand-sides matrix block B +*> stored in A(IOFFSET+1:M,N+1:N+NRHS) with Q(K)**H * B. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of +*> columns of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in] IOFFSET +*> \verbatim +*> IOFFSET is INTEGER +*> The number of rows of the matrix A that must be pivoted +*> but not factorized. IOFFSET >= 0. +*> +*> IOFFSET also represents the number of columns of the whole +*> original matrix A_orig that have been factorized +*> in the previous steps. +*> \endverbatim +*> +*> \param[in] KMAX +*> \verbatim +*> KMAX is INTEGER +*> +*> The first factorization stopping criterion. KMAX >= 0. +*> +*> The maximum number of columns of the matrix A to factorize, +*> i.e. the maximum factorization rank. +*> +*> a) If KMAX >= min(M-IOFFSET,N), then this stopping +*> criterion is not used, factorize columns +*> depending on ABSTOL and RELTOL. +*> +*> b) If KMAX = 0, then this stopping criterion is +*> satisfied on input and the routine exits immediately. +*> This means that the factorization is not performed, +*> the matrices A and B and the arrays TAU, IPIV +*> are not modified. +*> \endverbatim +*> +*> \param[in] ABSTOL +*> \verbatim +*> ABSTOL is DOUBLE PRECISION, cannot be NaN. +*> +*> The second factorization stopping criterion. +*> +*> The absolute tolerance (stopping threshold) for +*> maximum column 2-norm of the residual matrix. +*> The algorithm converges (stops the factorization) when +*> the maximum column 2-norm of the residual matrix +*> is less than or equal to ABSTOL. +*> +*> a) If ABSTOL < 0.0, then this stopping criterion is not +*> used, the routine factorizes columns depending +*> on KMAX and RELTOL. +*> This includes the case ABSTOL = -Inf. +*> +*> b) If 0.0 <= ABSTOL then the input value +*> of ABSTOL is used. +*> \endverbatim +*> +*> \param[in] RELTOL +*> \verbatim +*> RELTOL is DOUBLE PRECISION, cannot be NaN. +*> +*> The third factorization stopping criterion. +*> +*> The tolerance (stopping threshold) for the ratio of the +*> maximum column 2-norm of the residual matrix to the maximum +*> column 2-norm of the original matrix A_orig. The algorithm +*> converges (stops the factorization), when this ratio is +*> less than or equal to RELTOL. +*> +*> a) If RELTOL < 0.0, then this stopping criterion is not +*> used, the routine factorizes columns depending +*> on KMAX and ABSTOL. +*> This includes the case RELTOL = -Inf. +*> +*> d) If 0.0 <= RELTOL then the input value of RELTOL +*> is used. +*> \endverbatim +*> +*> \param[in] KP1 +*> \verbatim +*> KP1 is INTEGER +*> The index of the column with the maximum 2-norm in +*> the whole original matrix A_orig determined in the +*> main routine ZGEQP3RK. 1 <= KP1 <= N_orig_mat. +*> \endverbatim +*> +*> \param[in] MAXC2NRM +*> \verbatim +*> MAXC2NRM is DOUBLE PRECISION +*> The maximum column 2-norm of the whole original +*> matrix A_orig computed in the main routine ZGEQP3RK. +*> MAXC2NRM >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N+NRHS) +*> On entry: +*> the M-by-N matrix A and M-by-NRHS matrix B, as in +*> +*> N NRHS +*> array_A = M [ mat_A, mat_B ] +*> +*> On exit: +*> 1. The elements in block A(IOFFSET+1:M,1:K) below +*> the diagonal together with the array TAU represent +*> the orthogonal matrix Q(K) as a product of elementary +*> reflectors. +*> 2. The upper triangular block of the matrix A stored +*> in A(IOFFSET+1:M,1:K) is the triangular factor obtained. +*> 3. The block of the matrix A stored in A(1:IOFFSET,1:N) +*> has been accordingly pivoted, but not factorized. +*> 4. The rest of the array A, block A(IOFFSET+1:M,K+1:N+NRHS). +*> The left part A(IOFFSET+1:M,K+1:N) of this block +*> contains the residual of the matrix A, and, +*> if NRHS > 0, the right part of the block +*> A(IOFFSET+1:M,N+1:N+NRHS) contains the block of +*> the right-hand-side matrix B. Both these blocks have been +*> updated by multiplication from the left by Q(K)**H. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] K +*> \verbatim +*> K is INTEGER +*> Factorization rank of the matrix A, i.e. the rank of +*> the factor R, which is the same as the number of non-zero +*> rows of the factor R. 0 <= K <= min(M-IOFFSET,KMAX,N). +*> +*> K also represents the number of non-zero Householder +*> vectors. +*> \endverbatim +*> +*> \param[out] MAXC2NRMK +*> \verbatim +*> MAXC2NRMK is DOUBLE PRECISION +*> The maximum column 2-norm of the residual matrix, +*> when the factorization stopped at rank K. MAXC2NRMK >= 0. +*> \endverbatim +*> +*> \param[out] RELMAXC2NRMK +*> \verbatim +*> RELMAXC2NRMK is DOUBLE PRECISION +*> The ratio MAXC2NRMK / MAXC2NRM of the maximum column +*> 2-norm of the residual matrix (when the factorization +*> stopped at rank K) to the maximum column 2-norm of the +*> whole original matrix A. RELMAXC2NRMK >= 0. +*> \endverbatim +*> +*> \param[out] JPIV +*> \verbatim +*> JPIV is INTEGER array, dimension (N) +*> Column pivot indices, for 1 <= j <= N, column j +*> of the matrix A was interchanged with column JPIV(j). +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is COMPLEX*16 array, dimension (min(M-IOFFSET,N)) +*> The scalar factors of the elementary reflectors. +*> \endverbatim +*> +*> \param[in,out] VN1 +*> \verbatim +*> VN1 is DOUBLE PRECISION array, dimension (N) +*> The vector with the partial column norms. +*> \endverbatim +*> +*> \param[in,out] VN2 +*> \verbatim +*> VN2 is DOUBLE PRECISION array, dimension (N) +*> The vector with the exact column norms. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension (N-1) +*> Used in ZLARF subroutine to apply an elementary +*> reflector from the left. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> 1) INFO = 0: successful exit. +*> 2) If INFO = j_1, where 1 <= j_1 <= N, then NaN was +*> detected and the routine stops the computation. +*> The j_1-th column of the matrix A or the j_1-th +*> element of array TAU contains the first occurrence +*> of NaN in the factorization step K+1 ( when K columns +*> have been factorized ). +*> +*> On exit: +*> K is set to the number of +*> factorized columns without +*> exception. +*> MAXC2NRMK is set to NaN. +*> RELMAXC2NRMK is set to NaN. +*> TAU(K+1:min(M,N)) is not set and contains undefined +*> elements. If j_1=K+1, TAU(K+1) +*> may contain NaN. +*> 3) If INFO = j_2, where N+1 <= j_2 <= 2*N, then no NaN +*> was detected, but +Inf (or -Inf) was detected and +*> the routine continues the computation until completion. +*> The (j_2-N)-th column of the matrix A contains the first +*> occurrence of +Inf (or -Inf) in the factorization +*> step K+1 ( when K columns have been factorized ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup laqp2rk +* +*> \par References: +* ================ +*> [1] A Level 3 BLAS QR factorization algorithm with column pivoting developed in 1996. +*> G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain. +*> X. Sun, Computer Science Dept., Duke University, USA. +*> C. H. Bischof, Math. and Comp. Sci. Div., Argonne National Lab, USA. +*> A BLAS-3 version of the QR factorization with column pivoting. +*> LAPACK Working Note 114 +*> \htmlonly +*> https://www.netlib.org/lapack/lawnspdf/lawn114.pdf +*> \endhtmlonly +*> and in +*> SIAM J. Sci. Comput., 19(5):1486-1494, Sept. 1998. +*> \htmlonly +*> https://doi.org/10.1137/S1064827595296732 +*> \endhtmlonly +*> +*> [2] A partial column norm updating strategy developed in 2006. +*> Z. Drmac and Z. Bujanovic, Dept. of Math., University of Zagreb, Croatia. +*> On the failure of rank revealing QR factorization software – a case study. +*> LAPACK Working Note 176. +*> \htmlonly +*> http://www.netlib.org/lapack/lawnspdf/lawn176.pdf +*> \endhtmlonly +*> and in +*> ACM Trans. Math. Softw. 35, 2, Article 12 (July 2008), 28 pages. +*> \htmlonly +*> https://doi.org/10.1145/1377612.1377616 +*> \endhtmlonly +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> November 2023, Igor Kozachenko, James Demmel, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE ZLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, + $ KP1, MAXC2NRM, A, LDA, K, MAXC2NRMK, + $ RELMAXC2NRMK, JPIV, TAU, VN1, VN2, WORK, + $ INFO ) + IMPLICIT NONE +* +* -- LAPACK auxiliary routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER INFO, IOFFSET, KP1, K, KMAX, LDA, M, N, NRHS + DOUBLE PRECISION ABSTOL, MAXC2NRM, MAXC2NRMK, RELMAXC2NRMK, + $ RELTOL +* .. +* .. Array Arguments .. + INTEGER JPIV( * ) + DOUBLE PRECISION VN1( * ), VN2( * ) + COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + COMPLEX*16 CZERO, CONE + PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ), + $ CONE = ( 1.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + INTEGER I, ITEMP, J, JMAXC2NRM, KK, KP, MINMNFACT, + $ MINMNUPDT + DOUBLE PRECISION HUGEVAL, TAUNAN, TEMP, TEMP2, TOL3Z + COMPLEX*16 AIKK +* .. +* .. External Subroutines .. + EXTERNAL ZLARF, ZLARFG, ZSWAP +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, DCONJG, DIMAG, MAX, MIN, SQRT +* .. +* .. External Functions .. + LOGICAL DISNAN + INTEGER IDAMAX + DOUBLE PRECISION DLAMCH, DZNRM2 + EXTERNAL DISNAN, DLAMCH, IDAMAX, DZNRM2 +* .. +* .. Executable Statements .. +* +* Initialize INFO +* + INFO = 0 +* +* MINMNFACT in the smallest dimension of the submatrix +* A(IOFFSET+1:M,1:N) to be factorized. +* +* MINMNUPDT is the smallest dimension +* of the subarray A(IOFFSET+1:M,1:N+NRHS) to be udated, which +* contains the submatrices A(IOFFSET+1:M,1:N) and +* B(IOFFSET+1:M,1:NRHS) as column blocks. +* + MINMNFACT = MIN( M-IOFFSET, N ) + MINMNUPDT = MIN( M-IOFFSET, N+NRHS ) + KMAX = MIN( KMAX, MINMNFACT ) + TOL3Z = SQRT( DLAMCH( 'Epsilon' ) ) + HUGEVAL = DLAMCH( 'Overflow' ) +* +* Compute the factorization, KK is the lomn loop index. +* + DO KK = 1, KMAX +* + I = IOFFSET + KK +* + IF( I.EQ.1 ) THEN +* +* ============================================================ +* +* We are at the first column of the original whole matrix A, +* therefore we use the computed KP1 and MAXC2NRM from the +* main routine. +* + KP = KP1 +* +* ============================================================ +* + ELSE +* +* ============================================================ +* +* Determine the pivot column in KK-th step, i.e. the index +* of the column with the maximum 2-norm in the +* submatrix A(I:M,K:N). +* + KP = ( KK-1 ) + IDAMAX( N-KK+1, VN1( KK ), 1 ) +* +* Determine the maximum column 2-norm and the relative maximum +* column 2-norm of the submatrix A(I:M,KK:N) in step KK. +* RELMAXC2NRMK will be computed later, after somecondition +* checks on MAXC2NRMK. +* + MAXC2NRMK = VN1( KP ) +* +* ============================================================ +* +* Check if the submatrix A(I:M,KK:N) contains NaN, and set +* INFO parameter to the column number, where the first NaN +* is found and return from the routine. +* We need to check the condition only if the +* column index (same as row index) of the original whole +* matrix is larger than 1, since the condition for whole +* original matrix is checked in the main routine. +* + IF( DISNAN( MAXC2NRMK ) ) THEN +* +* Set K, the number of factorized columns. +* that are not zero. +* + K = KK - 1 + INFO = K + KP +* +* Set RELMAXC2NRMK to NaN. +* + RELMAXC2NRMK = MAXC2NRMK +* +* Array TAU(K+1:MINMNFACT) is not set and contains +* undefined elements. +* + RETURN + END IF +* +* ============================================================ +* +* Quick return, if the submatrix A(I:M,KK:N) is +* a zero matrix. +* We need to check the condition only if the +* column index (same as row index) of the original whole +* matrix is larger than 1, since the condition for whole +* original matrix is checked in the main routine. +* + IF( MAXC2NRMK.EQ.ZERO ) THEN +* +* Set K, the number of factorized columns. +* that are not zero. +* + K = KK - 1 + RELMAXC2NRMK = ZERO +* +* Set TAUs corresponding to the columns that were not +* factorized to ZERO, i.e. set TAU(KK:MINMNFACT) to CZERO. +* + DO J = KK, MINMNFACT + TAU( J ) = CZERO + END DO +* +* Return from the routine. +* + RETURN +* + END IF +* +* ============================================================ +* +* Check if the submatrix A(I:M,KK:N) contains Inf, +* set INFO parameter to the column number, where +* the first Inf is found plus N, and continue +* the computation. +* We need to check the condition only if the +* column index (same as row index) of the original whole +* matrix is larger than 1, since the condition for whole +* original matrix is checked in the main routine. +* + IF( INFO.EQ.0 .AND. MAXC2NRMK.GT.HUGEVAL ) THEN + INFO = N + KK - 1 + KP + END IF +* +* ============================================================ +* +* Test for the second and third stopping criteria. +* NOTE: There is no need to test for ABSTOL >= ZERO, since +* MAXC2NRMK is non-negative. Similarly, there is no need +* to test for RELTOL >= ZERO, since RELMAXC2NRMK is +* non-negative. +* We need to check the condition only if the +* column index (same as row index) of the original whole +* matrix is larger than 1, since the condition for whole +* original matrix is checked in the main routine. + + RELMAXC2NRMK = MAXC2NRMK / MAXC2NRM +* + IF( MAXC2NRMK.LE.ABSTOL .OR. RELMAXC2NRMK.LE.RELTOL ) THEN +* +* Set K, the number of factorized columns. +* + K = KK - 1 +* +* Set TAUs corresponding to the columns that were not +* factorized to ZERO, i.e. set TAU(KK:MINMNFACT) to CZERO. +* + DO J = KK, MINMNFACT + TAU( J ) = CZERO + END DO +* +* Return from the routine. +* + RETURN +* + END IF +* +* ============================================================ +* +* End ELSE of IF(I.EQ.1) +* + END IF +* +* =============================================================== +* +* If the pivot column is not the first column of the +* subblock A(1:M,KK:N): +* 1) swap the KK-th column and the KP-th pivot column +* in A(1:M,1:N); +* 2) copy the KK-th element into the KP-th element of the partial +* and exact 2-norm vectors VN1 and VN2. ( Swap is not needed +* for VN1 and VN2 since we use the element with the index +* larger than KK in the next loop step.) +* 3) Save the pivot interchange with the indices relative to the +* the original matrix A, not the block A(1:M,1:N). +* + IF( KP.NE.KK ) THEN + CALL ZSWAP( M, A( 1, KP ), 1, A( 1, KK ), 1 ) + VN1( KP ) = VN1( KK ) + VN2( KP ) = VN2( KK ) + ITEMP = JPIV( KP ) + JPIV( KP ) = JPIV( KK ) + JPIV( KK ) = ITEMP + END IF +* +* Generate elementary reflector H(KK) using the column A(I:M,KK), +* if the column has more than one element, otherwise +* the elementary reflector would be an identity matrix, +* and TAU(KK) = CZERO. +* + IF( I.LT.M ) THEN + CALL ZLARFG( M-I+1, A( I, KK ), A( I+1, KK ), 1, + $ TAU( KK ) ) + ELSE + TAU( KK ) = CZERO + END IF +* +* Check if TAU(KK) contains NaN, set INFO parameter +* to the column number where NaN is found and return from +* the routine. +* NOTE: There is no need to check TAU(KK) for Inf, +* since ZLARFG cannot produce TAU(KK) or Householder vector +* below the diagonal containing Inf. Only BETA on the diagonal, +* returned by ZLARFG can contain Inf, which requires +* TAU(KK) to contain NaN. Therefore, this case of generating Inf +* by ZLARFG is covered by checking TAU(KK) for NaN. +* + IF( DISNAN( DBLE( TAU(KK) ) ) ) THEN + TAUNAN = DBLE( TAU(KK) ) + ELSE IF( DISNAN( DIMAG( TAU(KK) ) ) ) THEN + TAUNAN = DIMAG( TAU(KK) ) + ELSE + TAUNAN = ZERO + END IF +* + IF( DISNAN( TAUNAN ) ) THEN + K = KK - 1 + INFO = KK +* +* Set MAXC2NRMK and RELMAXC2NRMK to NaN. +* + MAXC2NRMK = TAUNAN + RELMAXC2NRMK = TAUNAN +* +* Array TAU(KK:MINMNFACT) is not set and contains +* undefined elements, except the first element TAU(KK) = NaN. +* + RETURN + END IF +* +* Apply H(KK)**H to A(I:M,KK+1:N+NRHS) from the left. +* ( If M >= N, then at KK = N there is no residual matrix, +* i.e. no columns of A to update, only columns of B. +* If M < N, then at KK = M-IOFFSET, I = M and we have a +* one-row residual matrix in A and the elementary +* reflector is a unit matrix, TAU(KK) = CZERO, i.e. no update +* is needed for the residual matrix in A and the +* right-hand-side-matrix in B. +* Therefore, we update only if +* KK < MINMNUPDT = min(M-IOFFSET, N+NRHS) +* condition is satisfied, not only KK < N+NRHS ) +* + IF( KK.LT.MINMNUPDT ) THEN + AIKK = A( I, KK ) + A( I, KK ) = CONE + CALL ZLARF( 'Left', M-I+1, N+NRHS-KK, A( I, KK ), 1, + $ DCONJG( TAU( KK ) ), A( I, KK+1 ), LDA, + $ WORK( 1 ) ) + A( I, KK ) = AIKK + END IF +* + IF( KK.LT.MINMNFACT ) THEN +* +* Update the partial column 2-norms for the residual matrix, +* only if the residual matrix A(I+1:M,KK+1:N) exists, i.e. +* when KK < min(M-IOFFSET, N). +* + DO J = KK + 1, N + IF( VN1( J ).NE.ZERO ) THEN +* +* NOTE: The following lines follow from the analysis in +* Lapack Working Note 176. +* + TEMP = ONE - ( ABS( A( I, J ) ) / VN1( J ) )**2 + TEMP = MAX( TEMP, ZERO ) + TEMP2 = TEMP*( VN1( J ) / VN2( J ) )**2 + IF( TEMP2 .LE. TOL3Z ) THEN +* +* Compute the column 2-norm for the partial +* column A(I+1:M,J) by explicitly computing it, +* and store it in both partial 2-norm vector VN1 +* and exact column 2-norm vector VN2. +* + VN1( J ) = DZNRM2( M-I, A( I+1, J ), 1 ) + VN2( J ) = VN1( J ) +* + ELSE +* +* Update the column 2-norm for the partial +* column A(I+1:M,J) by removing one +* element A(I,J) and store it in partial +* 2-norm vector VN1. +* + VN1( J ) = VN1( J )*SQRT( TEMP ) +* + END IF + END IF + END DO +* + END IF +* +* End factorization loop +* + END DO +* +* If we reached this point, all colunms have been factorized, +* i.e. no condition was triggered to exit the routine. +* Set the number of factorized columns. +* + K = KMAX +* +* We reached the end of the loop, i.e. all KMAX columns were +* factorized, we need to set MAXC2NRMK and RELMAXC2NRMK before +* we return. +* + IF( K.LT.MINMNFACT ) THEN +* + JMAXC2NRM = K + IDAMAX( N-K, VN1( K+1 ), 1 ) + MAXC2NRMK = VN1( JMAXC2NRM ) +* + IF( K.EQ.0 ) THEN + RELMAXC2NRMK = ONE + ELSE + RELMAXC2NRMK = MAXC2NRMK / MAXC2NRM + END IF +* + ELSE + MAXC2NRMK = ZERO + RELMAXC2NRMK = ZERO + END IF +* +* We reached the end of the loop, i.e. all KMAX columns were +* factorized, set TAUs corresponding to the columns that were +* not factorized to ZERO, i.e. TAU(K+1:MINMNFACT) set to CZERO. +* + DO J = K + 1, MINMNFACT + TAU( J ) = CZERO + END DO +* + RETURN +* +* End of ZLAQP2RK +* + END diff --git a/lapack-netlib/SRC/zlaqp3rk.f b/lapack-netlib/SRC/zlaqp3rk.f new file mode 100644 index 000000000..7a9fdfd95 --- /dev/null +++ b/lapack-netlib/SRC/zlaqp3rk.f @@ -0,0 +1,947 @@ +*> \brief \b ZLAQP3RK computes a step of truncated QR factorization with column pivoting of a complex m-by-n matrix A using Level 3 BLAS and overwrites a complex m-by-nrhs matrix B with Q**H * B. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZLAQP3RK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZLAQP3RK( M, N, NRHS, IOFFSET, NB, ABSTOL, +* $ RELTOL, KP1, MAXC2NRM, A, LDA, DONE, KB, +* $ MAXC2NRMK, RELMAXC2NRMK, JPIV, TAU, +* $ VN1, VN2, AUXV, F, LDF, IWORK, INFO ) +* IMPLICIT NONE +* LOGICAL DONE +* INTEGER INFO, IOFFSET, KB, KP1, LDA, LDF, M, N, +* $ NB, NRHS +* DOUBLE PRECISION ABSTOL, MAXC2NRM, MAXC2NRMK, RELMAXC2NRMK, +* $ RELTOL +* .. +* .. Array Arguments .. +* INTEGER IWORK( * ), JPIV( * ) +* DOUBLE PRECISION VN1( * ), VN2( * ) +* COMPLEX*16 A( LDA, * ), AUXV( * ), F( LDF, * ), TAU( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZLAQP3RK computes a step of truncated QR factorization with column +*> pivoting of a complex M-by-N matrix A block A(IOFFSET+1:M,1:N) +*> by using Level 3 BLAS as +*> +*> A * P(KB) = Q(KB) * R(KB). +*> +*> The routine tries to factorize NB columns from A starting from +*> the row IOFFSET+1 and updates the residual matrix with BLAS 3 +*> xGEMM. The number of actually factorized columns is returned +*> is smaller than NB. +*> +*> Block A(1:IOFFSET,1:N) is accordingly pivoted, but not factorized. +*> +*> The routine also overwrites the right-hand-sides B matrix stored +*> in A(IOFFSET+1:M,1:N+1:N+NRHS) with Q(KB)**H * B. +*> +*> Cases when the number of factorized columns KB < NB: +*> +*> (1) In some cases, due to catastrophic cancellations, it cannot +*> factorize all NB columns and need to update the residual matrix. +*> Hence, the actual number of factorized columns in the block returned +*> in KB is smaller than NB. The logical DONE is returned as FALSE. +*> The factorization of the whole original matrix A_orig must proceed +*> with the next block. +*> +*> (2) Whenever the stopping criterion ABSTOL or RELTOL is satisfied, +*> the factorization of the whole original matrix A_orig is stopped, +*> the logical DONE is returned as TRUE. The number of factorized +*> columns which is smaller than NB is returned in KB. +*> +*> (3) In case both stopping criteria ABSTOL or RELTOL are not used, +*> and when the residual matrix is a zero matrix in some factorization +*> step KB, the factorization of the whole original matrix A_orig is +*> stopped, the logical DONE is returned as TRUE. The number of +*> factorized columns which is smaller than NB is returned in KB. +*> +*> (4) Whenever NaN is detected in the matrix A or in the array TAU, +*> the factorization of the whole original matrix A_orig is stopped, +*> the logical DONE is returned as TRUE. The number of factorized +*> columns which is smaller than NB is returned in KB. The INFO +*> parameter is set to the column index of the first NaN occurrence. +*> +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0 +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of +*> columns of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in] IOFFSET +*> \verbatim +*> IOFFSET is INTEGER +*> The number of rows of the matrix A that must be pivoted +*> but not factorized. IOFFSET >= 0. +*> +*> IOFFSET also represents the number of columns of the whole +*> original matrix A_orig that have been factorized +*> in the previous steps. +*> \endverbatim +*> +*> \param[in] NB +*> \verbatim +*> NB is INTEGER +*> Factorization block size, i.e the number of columns +*> to factorize in the matrix A. 0 <= NB +*> +*> If NB = 0, then the routine exits immediately. +*> This means that the factorization is not performed, +*> the matrices A and B and the arrays TAU, IPIV +*> are not modified. +*> \endverbatim +*> +*> \param[in] ABSTOL +*> \verbatim +*> ABSTOL is DOUBLE PRECISION, cannot be NaN. +*> +*> The absolute tolerance (stopping threshold) for +*> maximum column 2-norm of the residual matrix. +*> The algorithm converges (stops the factorization) when +*> the maximum column 2-norm of the residual matrix +*> is less than or equal to ABSTOL. +*> +*> a) If ABSTOL < 0.0, then this stopping criterion is not +*> used, the routine factorizes columns depending +*> on NB and RELTOL. +*> This includes the case ABSTOL = -Inf. +*> +*> b) If 0.0 <= ABSTOL then the input value +*> of ABSTOL is used. +*> \endverbatim +*> +*> \param[in] RELTOL +*> \verbatim +*> RELTOL is DOUBLE PRECISION, cannot be NaN. +*> +*> The tolerance (stopping threshold) for the ratio of the +*> maximum column 2-norm of the residual matrix to the maximum +*> column 2-norm of the original matrix A_orig. The algorithm +*> converges (stops the factorization), when this ratio is +*> less than or equal to RELTOL. +*> +*> a) If RELTOL < 0.0, then this stopping criterion is not +*> used, the routine factorizes columns depending +*> on NB and ABSTOL. +*> This includes the case RELTOL = -Inf. +*> +*> d) If 0.0 <= RELTOL then the input value of RELTOL +*> is used. +*> \endverbatim +*> +*> \param[in] KP1 +*> \verbatim +*> KP1 is INTEGER +*> The index of the column with the maximum 2-norm in +*> the whole original matrix A_orig determined in the +*> main routine ZGEQP3RK. 1 <= KP1 <= N_orig. +*> \endverbatim +*> +*> \param[in] MAXC2NRM +*> \verbatim +*> MAXC2NRM is DOUBLE PRECISION +*> The maximum column 2-norm of the whole original +*> matrix A_orig computed in the main routine ZGEQP3RK. +*> MAXC2NRM >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N+NRHS) +*> On entry: +*> the M-by-N matrix A and M-by-NRHS matrix B, as in +*> +*> N NRHS +*> array_A = M [ mat_A, mat_B ] +*> +*> On exit: +*> 1. The elements in block A(IOFFSET+1:M,1:KB) below +*> the diagonal together with the array TAU represent +*> the orthogonal matrix Q(KB) as a product of elementary +*> reflectors. +*> 2. The upper triangular block of the matrix A stored +*> in A(IOFFSET+1:M,1:KB) is the triangular factor obtained. +*> 3. The block of the matrix A stored in A(1:IOFFSET,1:N) +*> has been accordingly pivoted, but not factorized. +*> 4. The rest of the array A, block A(IOFFSET+1:M,KB+1:N+NRHS). +*> The left part A(IOFFSET+1:M,KB+1:N) of this block +*> contains the residual of the matrix A, and, +*> if NRHS > 0, the right part of the block +*> A(IOFFSET+1:M,N+1:N+NRHS) contains the block of +*> the right-hand-side matrix B. Both these blocks have been +*> updated by multiplication from the left by Q(KB)**H. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] +*> \verbatim +*> DONE is LOGICAL +*> TRUE: a) if the factorization completed before processing +*> all min(M-IOFFSET,NB,N) columns due to ABSTOL +*> or RELTOL criterion, +*> b) if the factorization completed before processing +*> all min(M-IOFFSET,NB,N) columns due to the +*> residual matrix being a ZERO matrix. +*> c) when NaN was detected in the matrix A +*> or in the array TAU. +*> FALSE: otherwise. +*> \endverbatim +*> +*> \param[out] KB +*> \verbatim +*> KB is INTEGER +*> Factorization rank of the matrix A, i.e. the rank of +*> the factor R, which is the same as the number of non-zero +*> rows of the factor R. 0 <= KB <= min(M-IOFFSET,NB,N). +*> +*> KB also represents the number of non-zero Householder +*> vectors. +*> \endverbatim +*> +*> \param[out] MAXC2NRMK +*> \verbatim +*> MAXC2NRMK is DOUBLE PRECISION +*> The maximum column 2-norm of the residual matrix, +*> when the factorization stopped at rank KB. MAXC2NRMK >= 0. +*> \endverbatim +*> +*> \param[out] RELMAXC2NRMK +*> \verbatim +*> RELMAXC2NRMK is DOUBLE PRECISION +*> The ratio MAXC2NRMK / MAXC2NRM of the maximum column +*> 2-norm of the residual matrix (when the factorization +*> stopped at rank KB) to the maximum column 2-norm of the +*> original matrix A_orig. RELMAXC2NRMK >= 0. +*> \endverbatim +*> +*> \param[out] JPIV +*> \verbatim +*> JPIV is INTEGER array, dimension (N) +*> Column pivot indices, for 1 <= j <= N, column j +*> of the matrix A was interchanged with column JPIV(j). +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is COMPLEX*16 array, dimension (min(M-IOFFSET,N)) +*> The scalar factors of the elementary reflectors. +*> \endverbatim +*> +*> \param[in,out] VN1 +*> \verbatim +*> VN1 is DOUBLE PRECISION array, dimension (N) +*> The vector with the partial column norms. +*> \endverbatim +*> +*> \param[in,out] VN2 +*> \verbatim +*> VN2 is DOUBLE PRECISION array, dimension (N) +*> The vector with the exact column norms. +*> \endverbatim +*> +*> \param[out] AUXV +*> \verbatim +*> AUXV is COMPLEX*16 array, dimension (NB) +*> Auxiliary vector. +*> \endverbatim +*> +*> \param[out] F +*> \verbatim +*> F is COMPLEX*16 array, dimension (LDF,NB) +*> Matrix F**H = L*(Y**H)*A. +*> \endverbatim +*> +*> \param[in] LDF +*> \verbatim +*> LDF is INTEGER +*> The leading dimension of the array F. LDF >= max(1,N+NRHS). +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (N-1). +*> Is a work array. ( IWORK is used to store indices +*> of "bad" columns for norm downdating in the residual +*> matrix ). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> 1) INFO = 0: successful exit. +*> 2) If INFO = j_1, where 1 <= j_1 <= N, then NaN was +*> detected and the routine stops the computation. +*> The j_1-th column of the matrix A or the j_1-th +*> element of array TAU contains the first occurrence +*> of NaN in the factorization step KB+1 ( when KB columns +*> have been factorized ). +*> +*> On exit: +*> KB is set to the number of +*> factorized columns without +*> exception. +*> MAXC2NRMK is set to NaN. +*> RELMAXC2NRMK is set to NaN. +*> TAU(KB+1:min(M,N)) is not set and contains undefined +*> elements. If j_1=KB+1, TAU(KB+1) +*> may contain NaN. +*> 3) If INFO = j_2, where N+1 <= j_2 <= 2*N, then no NaN +*> was detected, but +Inf (or -Inf) was detected and +*> the routine continues the computation until completion. +*> The (j_2-N)-th column of the matrix A contains the first +*> occurrence of +Inf (or -Inf) in the actorization +*> step KB+1 ( when KB columns have been factorized ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup laqp3rk +* +*> \par References: +* ================ +*> [1] A Level 3 BLAS QR factorization algorithm with column pivoting developed in 1996. +*> G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain. +*> X. Sun, Computer Science Dept., Duke University, USA. +*> C. H. Bischof, Math. and Comp. Sci. Div., Argonne National Lab, USA. +*> A BLAS-3 version of the QR factorization with column pivoting. +*> LAPACK Working Note 114 +*> \htmlonly +*> https://www.netlib.org/lapack/lawnspdf/lawn114.pdf +*> \endhtmlonly +*> and in +*> SIAM J. Sci. Comput., 19(5):1486-1494, Sept. 1998. +*> \htmlonly +*> https://doi.org/10.1137/S1064827595296732 +*> \endhtmlonly +*> +*> [2] A partial column norm updating strategy developed in 2006. +*> Z. Drmac and Z. Bujanovic, Dept. of Math., University of Zagreb, Croatia. +*> On the failure of rank revealing QR factorization software – a case study. +*> LAPACK Working Note 176. +*> \htmlonly +*> http://www.netlib.org/lapack/lawnspdf/lawn176.pdf +*> \endhtmlonly +*> and in +*> ACM Trans. Math. Softw. 35, 2, Article 12 (July 2008), 28 pages. +*> \htmlonly +*> https://doi.org/10.1145/1377612.1377616 +*> \endhtmlonly +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> November 2023, Igor Kozachenko, James Demmel, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE ZLAQP3RK( M, N, NRHS, IOFFSET, NB, ABSTOL, + $ RELTOL, KP1, MAXC2NRM, A, LDA, DONE, KB, + $ MAXC2NRMK, RELMAXC2NRMK, JPIV, TAU, + $ VN1, VN2, AUXV, F, LDF, IWORK, INFO ) + IMPLICIT NONE +* +* -- LAPACK auxiliary routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + LOGICAL DONE + INTEGER INFO, IOFFSET, KB, KP1, LDA, LDF, M, N, + $ NB, NRHS + DOUBLE PRECISION ABSTOL, MAXC2NRM, MAXC2NRMK, RELMAXC2NRMK, + $ RELTOL +* .. +* .. Array Arguments .. + INTEGER IWORK( * ), JPIV( * ) + DOUBLE PRECISION VN1( * ), VN2( * ) + COMPLEX*16 A( LDA, * ), AUXV( * ), F( LDF, * ), TAU( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + COMPLEX*16 CZERO, CONE + PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ), + $ CONE = ( 1.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + INTEGER ITEMP, J, K, MINMNFACT, MINMNUPDT, + $ LSTICC, KP, I, IF + DOUBLE PRECISION HUGEVAL, TAUNAN, TEMP, TEMP2, TOL3Z + COMPLEX*16 AIK +* .. +* .. External Subroutines .. + EXTERNAL ZGEMM, ZGEMV, ZLARFG, ZSWAP +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, DCONJG, DIMAG, MAX, MIN, SQRT +* .. +* .. External Functions .. + LOGICAL DISNAN + INTEGER IDAMAX + DOUBLE PRECISION DLAMCH, DZNRM2 + EXTERNAL DISNAN, DLAMCH, IDAMAX, DZNRM2 +* .. +* .. Executable Statements .. +* +* Initialize INFO +* + INFO = 0 +* +* MINMNFACT in the smallest dimension of the submatrix +* A(IOFFSET+1:M,1:N) to be factorized. +* + MINMNFACT = MIN( M-IOFFSET, N ) + MINMNUPDT = MIN( M-IOFFSET, N+NRHS ) + NB = MIN( NB, MINMNFACT ) + TOL3Z = SQRT( DLAMCH( 'Epsilon' ) ) + HUGEVAL = DLAMCH( 'Overflow' ) +* +* Compute factorization in a while loop over NB columns, +* K is the column index in the block A(1:M,1:N). +* + K = 0 + LSTICC = 0 + DONE = .FALSE. +* + DO WHILE ( K.LT.NB .AND. LSTICC.EQ.0 ) + K = K + 1 + I = IOFFSET + K +* + IF( I.EQ.1 ) THEN +* +* We are at the first column of the original whole matrix A_orig, +* therefore we use the computed KP1 and MAXC2NRM from the +* main routine. +* + KP = KP1 +* + ELSE +* +* Determine the pivot column in K-th step, i.e. the index +* of the column with the maximum 2-norm in the +* submatrix A(I:M,K:N). +* + KP = ( K-1 ) + IDAMAX( N-K+1, VN1( K ), 1 ) +* +* Determine the maximum column 2-norm and the relative maximum +* column 2-norm of the submatrix A(I:M,K:N) in step K. +* + MAXC2NRMK = VN1( KP ) +* +* ============================================================ +* +* Check if the submatrix A(I:M,K:N) contains NaN, set +* INFO parameter to the column number, where the first NaN +* is found and return from the routine. +* We need to check the condition only if the +* column index (same as row index) of the original whole +* matrix is larger than 1, since the condition for whole +* original matrix is checked in the main routine. +* + IF( DISNAN( MAXC2NRMK ) ) THEN +* + DONE = .TRUE. +* +* Set KB, the number of factorized partial columns +* that are non-zero in each step in the block, +* i.e. the rank of the factor R. +* Set IF, the number of processed rows in the block, which +* is the same as the number of processed rows in +* the original whole matrix A_orig. +* + KB = K - 1 + IF = I - 1 + INFO = KB + KP +* +* Set RELMAXC2NRMK to NaN. +* + RELMAXC2NRMK = MAXC2NRMK +* +* There is no need to apply the block reflector to the +* residual of the matrix A stored in A(KB+1:M,KB+1:N), +* since the submatrix contains NaN and we stop +* the computation. +* But, we need to apply the block reflector to the residual +* right hand sides stored in A(KB+1:M,N+1:N+NRHS), if the +* residual right hand sides exist. This occurs +* when ( NRHS != 0 AND KB <= (M-IOFFSET) ): +* +* A(I+1:M,N+1:N+NRHS) := A(I+1:M,N+1:N+NRHS) - +* A(I+1:M,1:KB) * F(N+1:N+NRHS,1:KB)**H. + + IF( NRHS.GT.0 .AND. KB.LT.(M-IOFFSET) ) THEN + CALL ZGEMM( 'No transpose', 'Conjugate transpose', + $ M-IF, NRHS, KB, -CONE, A( IF+1, 1 ), LDA, + $ F( N+1, 1 ), LDF, CONE, A( IF+1, N+1 ), LDA ) + END IF +* +* There is no need to recompute the 2-norm of the +* difficult columns, since we stop the factorization. +* +* Array TAU(KF+1:MINMNFACT) is not set and contains +* undefined elements. +* +* Return from the routine. +* + RETURN + END IF +* +* Quick return, if the submatrix A(I:M,K:N) is +* a zero matrix. We need to check it only if the column index +* (same as row index) is larger than 1, since the condition +* for the whole original matrix A_orig is checked in the main +* routine. +* + IF( MAXC2NRMK.EQ.ZERO ) THEN +* + DONE = .TRUE. +* +* Set KB, the number of factorized partial columns +* that are non-zero in each step in the block, +* i.e. the rank of the factor R. +* Set IF, the number of processed rows in the block, which +* is the same as the number of processed rows in +* the original whole matrix A_orig. +* + KB = K - 1 + IF = I - 1 + RELMAXC2NRMK = ZERO +* +* There is no need to apply the block reflector to the +* residual of the matrix A stored in A(KB+1:M,KB+1:N), +* since the submatrix is zero and we stop the computation. +* But, we need to apply the block reflector to the residual +* right hand sides stored in A(KB+1:M,N+1:N+NRHS), if the +* residual right hand sides exist. This occurs +* when ( NRHS != 0 AND KB <= (M-IOFFSET) ): +* +* A(I+1:M,N+1:N+NRHS) := A(I+1:M,N+1:N+NRHS) - +* A(I+1:M,1:KB) * F(N+1:N+NRHS,1:KB)**H. +* + IF( NRHS.GT.0 .AND. KB.LT.(M-IOFFSET) ) THEN + CALL ZGEMM( 'No transpose', 'Conjugate transpose', + $ M-IF, NRHS, KB, -CONE, A( IF+1, 1 ), LDA, + $ F( N+1, 1 ), LDF, CONE, A( IF+1, N+1 ), LDA ) + END IF +* +* There is no need to recompute the 2-norm of the +* difficult columns, since we stop the factorization. +* +* Set TAUs corresponding to the columns that were not +* factorized to ZERO, i.e. set TAU(KB+1:MINMNFACT) = CZERO, +* which is equivalent to seting TAU(K:MINMNFACT) = CZERO. +* + DO J = K, MINMNFACT + TAU( J ) = CZERO + END DO +* +* Return from the routine. +* + RETURN +* + END IF +* +* ============================================================ +* +* Check if the submatrix A(I:M,K:N) contains Inf, +* set INFO parameter to the column number, where +* the first Inf is found plus N, and continue +* the computation. +* We need to check the condition only if the +* column index (same as row index) of the original whole +* matrix is larger than 1, since the condition for whole +* original matrix is checked in the main routine. +* + IF( INFO.EQ.0 .AND. MAXC2NRMK.GT.HUGEVAL ) THEN + INFO = N + K - 1 + KP + END IF +* +* ============================================================ +* +* Test for the second and third tolerance stopping criteria. +* NOTE: There is no need to test for ABSTOL.GE.ZERO, since +* MAXC2NRMK is non-negative. Similarly, there is no need +* to test for RELTOL.GE.ZERO, since RELMAXC2NRMK is +* non-negative. +* We need to check the condition only if the +* column index (same as row index) of the original whole +* matrix is larger than 1, since the condition for whole +* original matrix is checked in the main routine. +* + RELMAXC2NRMK = MAXC2NRMK / MAXC2NRM +* + IF( MAXC2NRMK.LE.ABSTOL .OR. RELMAXC2NRMK.LE.RELTOL ) THEN +* + DONE = .TRUE. +* +* Set KB, the number of factorized partial columns +* that are non-zero in each step in the block, +* i.e. the rank of the factor R. +* Set IF, the number of processed rows in the block, which +* is the same as the number of processed rows in +* the original whole matrix A_orig; +* + KB = K - 1 + IF = I - 1 +* +* Apply the block reflector to the residual of the +* matrix A and the residual of the right hand sides B, if +* the residual matrix and and/or the residual of the right +* hand sides exist, i.e. if the submatrix +* A(I+1:M,KB+1:N+NRHS) exists. This occurs when +* KB < MINMNUPDT = min( M-IOFFSET, N+NRHS ): +* +* A(IF+1:M,K+1:N+NRHS) := A(IF+1:M,KB+1:N+NRHS) - +* A(IF+1:M,1:KB) * F(KB+1:N+NRHS,1:KB)**H. +* + IF( KB.LT.MINMNUPDT ) THEN + CALL ZGEMM( 'No transpose', 'Conjugate transpose', + $ M-IF, N+NRHS-KB, KB,-CONE, A( IF+1, 1 ), LDA, + $ F( KB+1, 1 ), LDF, CONE, A( IF+1, KB+1 ), LDA ) + END IF +* +* There is no need to recompute the 2-norm of the +* difficult columns, since we stop the factorization. +* +* Set TAUs corresponding to the columns that were not +* factorized to ZERO, i.e. set TAU(KB+1:MINMNFACT) = CZERO, +* which is equivalent to seting TAU(K:MINMNFACT) = CZERO. +* + DO J = K, MINMNFACT + TAU( J ) = CZERO + END DO +* +* Return from the routine. +* + RETURN +* + END IF +* +* ============================================================ +* +* End ELSE of IF(I.EQ.1) +* + END IF +* +* =============================================================== +* +* If the pivot column is not the first column of the +* subblock A(1:M,K:N): +* 1) swap the K-th column and the KP-th pivot column +* in A(1:M,1:N); +* 2) swap the K-th row and the KP-th row in F(1:N,1:K-1) +* 3) copy the K-th element into the KP-th element of the partial +* and exact 2-norm vectors VN1 and VN2. (Swap is not needed +* for VN1 and VN2 since we use the element with the index +* larger than K in the next loop step.) +* 4) Save the pivot interchange with the indices relative to the +* the original matrix A_orig, not the block A(1:M,1:N). +* + IF( KP.NE.K ) THEN + CALL ZSWAP( M, A( 1, KP ), 1, A( 1, K ), 1 ) + CALL ZSWAP( K-1, F( KP, 1 ), LDF, F( K, 1 ), LDF ) + VN1( KP ) = VN1( K ) + VN2( KP ) = VN2( K ) + ITEMP = JPIV( KP ) + JPIV( KP ) = JPIV( K ) + JPIV( K ) = ITEMP + END IF +* +* Apply previous Householder reflectors to column K: +* A(I:M,K) := A(I:M,K) - A(I:M,1:K-1)*F(K,1:K-1)**H. +* + IF( K.GT.1 ) THEN + DO J = 1, K - 1 + F( K, J ) = DCONJG( F( K, J ) ) + END DO + CALL ZGEMV( 'No transpose', M-I+1, K-1, -CONE, A( I, 1 ), + $ LDA, F( K, 1 ), LDF, CONE, A( I, K ), 1 ) + DO J = 1, K - 1 + F( K, J ) = DCONJG( F( K, J ) ) + END DO + END IF +* +* Generate elementary reflector H(k) using the column A(I:M,K). +* + IF( I.LT.M ) THEN + CALL ZLARFG( M-I+1, A( I, K ), A( I+1, K ), 1, TAU( K ) ) + ELSE + TAU( K ) = CZERO + END IF +* +* Check if TAU(K) contains NaN, set INFO parameter +* to the column number where NaN is found and return from +* the routine. +* NOTE: There is no need to check TAU(K) for Inf, +* since ZLARFG cannot produce TAU(KK) or Householder vector +* below the diagonal containing Inf. Only BETA on the diagonal, +* returned by ZLARFG can contain Inf, which requires +* TAU(K) to contain NaN. Therefore, this case of generating Inf +* by ZLARFG is covered by checking TAU(K) for NaN. +* + IF( DISNAN( DBLE( TAU(K) ) ) ) THEN + TAUNAN = DBLE( TAU(K) ) + ELSE IF( DISNAN( DIMAG( TAU(K) ) ) ) THEN + TAUNAN = DIMAG( TAU(K) ) + ELSE + TAUNAN = ZERO + END IF +* + IF( DISNAN( TAUNAN ) ) THEN +* + DONE = .TRUE. +* +* Set KB, the number of factorized partial columns +* that are non-zero in each step in the block, +* i.e. the rank of the factor R. +* Set IF, the number of processed rows in the block, which +* is the same as the number of processed rows in +* the original whole matrix A_orig. +* + KB = K - 1 + IF = I - 1 + INFO = K +* +* Set MAXC2NRMK and RELMAXC2NRMK to NaN. +* + MAXC2NRMK = TAUNAN + RELMAXC2NRMK = TAUNAN +* +* There is no need to apply the block reflector to the +* residual of the matrix A stored in A(KB+1:M,KB+1:N), +* since the submatrix contains NaN and we stop +* the computation. +* But, we need to apply the block reflector to the residual +* right hand sides stored in A(KB+1:M,N+1:N+NRHS), if the +* residual right hand sides exist. This occurs +* when ( NRHS != 0 AND KB <= (M-IOFFSET) ): +* +* A(I+1:M,N+1:N+NRHS) := A(I+1:M,N+1:N+NRHS) - +* A(I+1:M,1:KB) * F(N+1:N+NRHS,1:KB)**H. +* + IF( NRHS.GT.0 .AND. KB.LT.(M-IOFFSET) ) THEN + CALL ZGEMM( 'No transpose', 'Conjugate transpose', + $ M-IF, NRHS, KB, -CONE, A( IF+1, 1 ), LDA, + $ F( N+1, 1 ), LDF, CONE, A( IF+1, N+1 ), LDA ) + END IF +* +* There is no need to recompute the 2-norm of the +* difficult columns, since we stop the factorization. +* +* Array TAU(KF+1:MINMNFACT) is not set and contains +* undefined elements. +* +* Return from the routine. +* + RETURN + END IF +* +* =============================================================== +* + AIK = A( I, K ) + A( I, K ) = CONE +* +* =============================================================== +* +* Compute the current K-th column of F: +* 1) F(K+1:N,K) := tau(K) * A(I:M,K+1:N)**H * A(I:M,K). +* + IF( K.LT.N+NRHS ) THEN + CALL ZGEMV( 'Conjugate transpose', M-I+1, N+NRHS-K, + $ TAU( K ), A( I, K+1 ), LDA, A( I, K ), 1, + $ CZERO, F( K+1, K ), 1 ) + END IF +* +* 2) Zero out elements above and on the diagonal of the +* column K in matrix F, i.e elements F(1:K,K). +* + DO J = 1, K + F( J, K ) = CZERO + END DO +* +* 3) Incremental updating of the K-th column of F: +* F(1:N,K) := F(1:N,K) - tau(K) * F(1:N,1:K-1) * A(I:M,1:K-1)**H +* * A(I:M,K). +* + IF( K.GT.1 ) THEN + CALL ZGEMV( 'Conjugate Transpose', M-I+1, K-1, -TAU( K ), + $ A( I, 1 ), LDA, A( I, K ), 1, CZERO, + $ AUXV( 1 ), 1 ) +* + CALL ZGEMV( 'No transpose', N+NRHS, K-1, CONE, + $ F( 1, 1 ), LDF, AUXV( 1 ), 1, CONE, + $ F( 1, K ), 1 ) + END IF +* +* =============================================================== +* +* Update the current I-th row of A: +* A(I,K+1:N+NRHS) := A(I,K+1:N+NRHS) +* - A(I,1:K)*F(K+1:N+NRHS,1:K)**H. +* + IF( K.LT.N+NRHS ) THEN + CALL ZGEMM( 'No transpose', 'Conjugate transpose', + $ 1, N+NRHS-K, K, -CONE, A( I, 1 ), LDA, + $ F( K+1, 1 ), LDF, CONE, A( I, K+1 ), LDA ) + END IF +* + A( I, K ) = AIK +* +* Update the partial column 2-norms for the residual matrix, +* only if the residual matrix A(I+1:M,K+1:N) exists, i.e. +* when K < MINMNFACT = min( M-IOFFSET, N ). +* + IF( K.LT.MINMNFACT ) THEN +* + DO J = K + 1, N + IF( VN1( J ).NE.ZERO ) THEN +* +* NOTE: The following lines follow from the analysis in +* Lapack Working Note 176. +* + TEMP = ABS( A( I, J ) ) / VN1( J ) + TEMP = MAX( ZERO, ( ONE+TEMP )*( ONE-TEMP ) ) + TEMP2 = TEMP*( VN1( J ) / VN2( J ) )**2 + IF( TEMP2.LE.TOL3Z ) THEN +* +* At J-index, we have a difficult column for the +* update of the 2-norm. Save the index of the previous +* difficult column in IWORK(J-1). +* NOTE: ILSTCC > 1, threfore we can use IWORK only +* with N-1 elements, where the elements are +* shifted by 1 to the left. +* + IWORK( J-1 ) = LSTICC +* +* Set the index of the last difficult column LSTICC. +* + LSTICC = J +* + ELSE + VN1( J ) = VN1( J )*SQRT( TEMP ) + END IF + END IF + END DO +* + END IF +* +* End of while loop. +* + END DO +* +* Now, afler the loop: +* Set KB, the number of factorized columns in the block; +* Set IF, the number of processed rows in the block, which +* is the same as the number of processed rows in +* the original whole matrix A_orig, IF = IOFFSET + KB. +* + KB = K + IF = I +* +* Apply the block reflector to the residual of the matrix A +* and the residual of the right hand sides B, if the residual +* matrix and and/or the residual of the right hand sides +* exist, i.e. if the submatrix A(I+1:M,KB+1:N+NRHS) exists. +* This occurs when KB < MINMNUPDT = min( M-IOFFSET, N+NRHS ): +* +* A(IF+1:M,K+1:N+NRHS) := A(IF+1:M,KB+1:N+NRHS) - +* A(IF+1:M,1:KB) * F(KB+1:N+NRHS,1:KB)**H. +* + IF( KB.LT.MINMNUPDT ) THEN + CALL ZGEMM( 'No transpose', 'Conjugate transpose', + $ M-IF, N+NRHS-KB, KB, -CONE, A( IF+1, 1 ), LDA, + $ F( KB+1, 1 ), LDF, CONE, A( IF+1, KB+1 ), LDA ) + END IF +* +* Recompute the 2-norm of the difficult columns. +* Loop over the index of the difficult columns from the largest +* to the smallest index. +* + DO WHILE( LSTICC.GT.0 ) +* +* LSTICC is the index of the last difficult column is greater +* than 1. +* ITEMP is the index of the previous difficult column. +* + ITEMP = IWORK( LSTICC-1 ) +* +* Compute the 2-norm explicilty for the last difficult column and +* save it in the partial and exact 2-norm vectors VN1 and VN2. +* +* NOTE: The computation of VN1( LSTICC ) relies on the fact that +* DZNRM2 does not fail on vectors with norm below the value of +* SQRT(DLAMCH('S')) +* + VN1( LSTICC ) = DZNRM2( M-IF, A( IF+1, LSTICC ), 1 ) + VN2( LSTICC ) = VN1( LSTICC ) +* +* Downdate the index of the last difficult column to +* the index of the previous difficult column. +* + LSTICC = ITEMP +* + END DO +* + RETURN +* +* End of ZLAQP3RK +* + END From 40109c03927e3b5249f6e34dfe9279b15075fd8a Mon Sep 17 00:00:00 2001 From: Martin Kroeker Date: Wed, 15 Nov 2023 09:50:30 +0100 Subject: [PATCH 04/60] Implement truncated QR with pivoting (Reference-LAPACK PR 891) --- lapack-netlib/TESTING/EIG/alareq.f | 6 +++--- lapack-netlib/TESTING/EIG/alarqg.f | 6 +++--- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/lapack-netlib/TESTING/EIG/alareq.f b/lapack-netlib/TESTING/EIG/alareq.f index 2585a686a..2cbe6db38 100644 --- a/lapack-netlib/TESTING/EIG/alareq.f +++ b/lapack-netlib/TESTING/EIG/alareq.f @@ -28,12 +28,12 @@ *> to evaluate the input line which requested NMATS matrix types for *> PATH. The flow of control is as follows: *> -*> If NMATS = NTYPES then +*> IF NMATS = NTYPES THEN *> DOTYPE(1:NTYPES) = .TRUE. -*> else +*> ELSE *> Read the next input line for NMATS matrix types *> Set DOTYPE(I) = .TRUE. for each valid type I -*> endif +*> END IF *> \endverbatim * * Arguments: diff --git a/lapack-netlib/TESTING/EIG/alarqg.f b/lapack-netlib/TESTING/EIG/alarqg.f index 6e2e6e7ec..b9fb88c65 100644 --- a/lapack-netlib/TESTING/EIG/alarqg.f +++ b/lapack-netlib/TESTING/EIG/alarqg.f @@ -28,12 +28,12 @@ *> to evaluate the input line which requested NMATS matrix types for *> PATH. The flow of control is as follows: *> -*> If NMATS = NTYPES then +*> IF NMATS = NTYPES THEN *> DOTYPE(1:NTYPES) = .TRUE. -*> else +*> ELSE *> Read the next input line for NMATS matrix types *> Set DOTYPE(I) = .TRUE. for each valid type I -*> endif +*> END IF *> \endverbatim * * Arguments: From 387830b9d5df8956483d515fce3025502d325dea Mon Sep 17 00:00:00 2001 From: Martin Kroeker Date: Wed, 15 Nov 2023 09:53:06 +0100 Subject: [PATCH 05/60] Implement truncated QR with pivoting (Reference-LAPACK PR 891) --- lapack-netlib/TESTING/LIN/CMakeLists.txt | 11 +- lapack-netlib/TESTING/LIN/Makefile | 48 +- lapack-netlib/TESTING/LIN/alaerh.f | 17 + lapack-netlib/TESTING/LIN/alahd.f | 62 +- lapack-netlib/TESTING/LIN/alareq.f | 6 +- lapack-netlib/TESTING/LIN/cchkaa.F | 43 +- lapack-netlib/TESTING/LIN/cchkqp3rk.f | 836 +++++++++++++++++++++++ lapack-netlib/TESTING/LIN/clatb4.f | 121 +++- lapack-netlib/TESTING/LIN/cqpt01.f | 23 +- lapack-netlib/TESTING/LIN/cqrt11.f | 4 +- lapack-netlib/TESTING/LIN/cqrt12.f | 19 +- lapack-netlib/TESTING/LIN/dchkaa.F | 48 +- lapack-netlib/TESTING/LIN/dchkq3.f | 2 +- lapack-netlib/TESTING/LIN/dchkqp3rk.f | 832 ++++++++++++++++++++++ lapack-netlib/TESTING/LIN/dlatb4.f | 123 +++- lapack-netlib/TESTING/LIN/dqpt01.f | 42 +- lapack-netlib/TESTING/LIN/dqrt11.f | 4 +- lapack-netlib/TESTING/LIN/dqrt12.f | 22 +- lapack-netlib/TESTING/LIN/schkaa.F | 48 +- lapack-netlib/TESTING/LIN/schkqp3rk.f | 831 ++++++++++++++++++++++ lapack-netlib/TESTING/LIN/slatb4.f | 121 +++- lapack-netlib/TESTING/LIN/sqpt01.f | 23 +- lapack-netlib/TESTING/LIN/sqrt11.f | 4 +- lapack-netlib/TESTING/LIN/sqrt12.f | 18 +- lapack-netlib/TESTING/LIN/zchkaa.F | 59 +- lapack-netlib/TESTING/LIN/zchkqp3rk.f | 836 +++++++++++++++++++++++ lapack-netlib/TESTING/LIN/zlatb4.f | 121 +++- lapack-netlib/TESTING/LIN/zqpt01.f | 22 +- lapack-netlib/TESTING/LIN/zqrt11.f | 4 +- lapack-netlib/TESTING/LIN/zqrt12.f | 20 +- 30 files changed, 4132 insertions(+), 238 deletions(-) create mode 100644 lapack-netlib/TESTING/LIN/cchkqp3rk.f create mode 100644 lapack-netlib/TESTING/LIN/dchkqp3rk.f create mode 100644 lapack-netlib/TESTING/LIN/schkqp3rk.f create mode 100644 lapack-netlib/TESTING/LIN/zchkqp3rk.f diff --git a/lapack-netlib/TESTING/LIN/CMakeLists.txt b/lapack-netlib/TESTING/LIN/CMakeLists.txt index 676857a80..e28818c76 100644 --- a/lapack-netlib/TESTING/LIN/CMakeLists.txt +++ b/lapack-netlib/TESTING/LIN/CMakeLists.txt @@ -9,7 +9,7 @@ set(DZLNTST dlaord.f) 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 + schkpt.f schkq3.f schkqp3rk.f schkql.f schkqr.f schkrq.f schksp.f schksy.f schksy_rook.f schksy_rk.f schksy_aa.f schksy_aa_2stage.f schktb.f schktp.f schktr.f @@ -56,7 +56,7 @@ set(CLINTST cchkaa.F cchkhe.f cchkhe_rook.f cchkhe_rk.f cchkhe_aa.f cchkhe_aa_2stage.f cchkhp.f cchklq.f cchkpb.f - cchkpo.f cchkps.f cchkpp.f cchkpt.f cchkq3.f cchkql.f + cchkpo.f cchkps.f cchkpp.f cchkpt.f cchkq3.f cchkqp3rk.f cchkql.f cchkqr.f cchkrq.f cchksp.f cchksy.f cchksy_rook.f cchksy_rk.f cchksy_aa.f cchksy_aa_2stage.f cchktb.f @@ -110,7 +110,7 @@ endif() 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 + dchkpt.f dchkq3.f dchkqp3rk.f dchkql.f dchkqr.f dchkrq.f dchksp.f dchksy.f dchksy_rook.f dchksy_rk.f dchksy_aa.f dchksy_aa_2stage.f dchktb.f dchktp.f dchktr.f @@ -158,7 +158,7 @@ set(ZLINTST zchkaa.F zchkhe.f zchkhe_rook.f zchkhe_rk.f zchkhe_aa.f zchkhe_aa_2stage.f zchkhp.f zchklq.f zchkpb.f - zchkpo.f zchkps.f zchkpp.f zchkpt.f zchkq3.f zchkql.f + zchkpo.f zchkps.f zchkpp.f zchkpt.f zchkq3.f zchkqp3rk.f zchkql.f zchkqr.f zchkrq.f zchksp.f zchksy.f zchksy_rook.f zchksy_rk.f zchksy_aa.f zchksy_aa_2stage.f zchktb.f @@ -239,8 +239,7 @@ set(ZLINTSTRFP zchkrfp.f zdrvrfp.f zdrvrf1.f zdrvrf2.f zdrvrf3.f zdrvrf4.f zerrr macro(add_lin_executable name) add_executable(${name} ${ARGN}) - target_link_libraries(${name} openblas${SUFFIX64_UNDERSCORE}) -#${TMGLIB} ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES}) + target_link_libraries(${name} ${TMGLIB} ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES}) endmacro() if(BUILD_SINGLE) diff --git a/lapack-netlib/TESTING/LIN/Makefile b/lapack-netlib/TESTING/LIN/Makefile index 64abc4dba..46e096c2f 100644 --- a/lapack-netlib/TESTING/LIN/Makefile +++ b/lapack-netlib/TESTING/LIN/Makefile @@ -45,7 +45,7 @@ DZLNTST = dlaord.o 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 \ + schkpt.o schkq3.o schkqp3rk.o schkql.o schkqr.o schkrq.o \ schksp.o schksy.o schksy_rook.o schksy_rk.o \ schksy_aa.o schksy_aa_2stage.o schktb.o schktp.o schktr.o \ schktz.o \ @@ -89,7 +89,7 @@ CLINTST = cchkaa.o \ cchkeq.o cchkgb.o cchkge.o cchkgt.o \ cchkhe.o cchkhe_rook.o cchkhe_rk.o \ cchkhe_aa.o cchkhe_aa_2stage.o cchkhp.o cchklq.o cchkpb.o \ - cchkpo.o cchkps.o cchkpp.o cchkpt.o cchkq3.o cchkql.o \ + cchkpo.o cchkps.o cchkpp.o cchkpt.o cchkq3.o cchkqp3rk.o cchkql.o \ cchkqr.o cchkrq.o cchksp.o cchksy.o cchksy_rook.o cchksy_rk.o \ cchksy_aa.o cchksy_aa_2stage.o cchktb.o \ cchktp.o cchktr.o cchktz.o \ @@ -137,7 +137,7 @@ endif 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 \ + dchkpt.o dchkq3.o dchkqp3rk.o dchkql.o dchkqr.o dchkrq.o \ dchksp.o dchksy.o dchksy_rook.o dchksy_rk.o \ dchksy_aa.o dchksy_aa_2stage.o dchktb.o dchktp.o dchktr.o \ dchktz.o \ @@ -182,7 +182,7 @@ ZLINTST = zchkaa.o \ zchkeq.o zchkgb.o zchkge.o zchkgt.o \ zchkhe.o zchkhe_rook.o zchkhe_rk.o zchkhe_aa.o zchkhe_aa_2stage.o \ zchkhp.o zchklq.o zchkpb.o \ - zchkpo.o zchkps.o zchkpp.o zchkpt.o zchkq3.o zchkql.o \ + zchkpo.o zchkps.o zchkpp.o zchkpt.o zchkq3.o zchkqp3rk.o zchkql.o \ zchkqr.o zchkrq.o zchksp.o zchksy.o zchksy_rook.o zchksy_rk.o \ zchksy_aa.o zchksy_aa_2stage.o zchktb.o \ zchktp.o zchktr.o zchktz.o \ @@ -269,35 +269,35 @@ proto-double: xlintstds xlintstrfd proto-complex: xlintstrfc proto-complex16: xlintstzc xlintstrfz -xlintsts: $(ALINTST) $(SLINTST) $(SCLNTST) $(TMGLIB) $(VARLIB) ../$(LAPACKLIB) $(XBLASLIB) $(BLASLIB) - $(LOADER) $(FFLAGS) $(LDFLAGS) -o $@ $^ +xlintsts: $(ALINTST) $(SLINTST) $(SCLNTST) $(TMGLIB) $(VARLIB) $(LAPACKLIB) $(XBLASLIB) $(BLASLIB) + $(FC) $(FFLAGS) $(LDFLAGS) -o $@ $^ -xlintstc: $(ALINTST) $(CLINTST) $(SCLNTST) $(TMGLIB) $(VARLIB) ../$(LAPACKLIB) $(XBLASLIB) $(BLASLIB) - $(LOADER) $(FFLAGS) $(LDFLAGS) -o $@ $^ +xlintstc: $(ALINTST) $(CLINTST) $(SCLNTST) $(TMGLIB) $(VARLIB) $(LAPACKLIB) $(XBLASLIB) $(BLASLIB) + $(FC) $(FFLAGS) $(LDFLAGS) -o $@ $^ -xlintstd: $(ALINTST) $(DLINTST) $(DZLNTST) $(TMGLIB) $(VARLIB) ../$(LAPACKLIB) $(XBLASLIB) $(BLASLIB) - $(LOADER) $(FFLAGS) $(LDFLAGS) -o $@ $^ +xlintstd: $(ALINTST) $(DLINTST) $(DZLNTST) $(TMGLIB) $(VARLIB) $(LAPACKLIB) $(XBLASLIB) $(BLASLIB) + $(FC) $(FFLAGS) $(LDFLAGS) -o $@ $^ -xlintstz: $(ALINTST) $(ZLINTST) $(DZLNTST) $(TMGLIB) $(VARLIB) ../$(LAPACKLIB) $(XBLASLIB) $(BLASLIB) - $(LOADER) $(FFLAGS) $(LDFLAGS) -o $@ $^ +xlintstz: $(ALINTST) $(ZLINTST) $(DZLNTST) $(TMGLIB) $(VARLIB) $(LAPACKLIB) $(XBLASLIB) $(BLASLIB) + $(FC) $(FFLAGS) $(LDFLAGS) -o $@ $^ -xlintstds: $(DSLINTST) $(TMGLIB) $(VARLIB) ../$(LAPACKLIB) $(BLASLIB) - $(LOADER) $(FFLAGS) $(LDFLAGS) -o $@ $^ +xlintstds: $(DSLINTST) $(TMGLIB) $(VARLIB) $(LAPACKLIB) $(BLASLIB) + $(FC) $(FFLAGS) $(LDFLAGS) -o $@ $^ -xlintstzc: $(ZCLINTST) $(TMGLIB) $(VARLIB) ../$(LAPACKLIB) $(BLASLIB) - $(LOADER) $(FFLAGS) $(LDFLAGS) -o $@ $^ +xlintstzc: $(ZCLINTST) $(TMGLIB) $(VARLIB) $(LAPACKLIB) $(BLASLIB) + $(FC) $(FFLAGS) $(LDFLAGS) -o $@ $^ -xlintstrfs: $(SLINTSTRFP) $(TMGLIB) $(VARLIB) ../$(LAPACKLIB) $(BLASLIB) - $(LOADER) $(FFLAGS) $(LDFLAGS) -o $@ $^ +xlintstrfs: $(SLINTSTRFP) $(TMGLIB) $(VARLIB) $(LAPACKLIB) $(BLASLIB) + $(FC) $(FFLAGS) $(LDFLAGS) -o $@ $^ -xlintstrfd: $(DLINTSTRFP) $(TMGLIB) $(VARLIB) ../$(LAPACKLIB) $(BLASLIB) - $(LOADER) $(FFLAGS) $(LDFLAGS) -o $@ $^ +xlintstrfd: $(DLINTSTRFP) $(TMGLIB) $(VARLIB) $(LAPACKLIB) $(BLASLIB) + $(FC) $(FFLAGS) $(LDFLAGS) -o $@ $^ -xlintstrfc: $(CLINTSTRFP) $(TMGLIB) $(VARLIB) ../$(LAPACKLIB) $(BLASLIB) - $(LOADER) $(FFLAGS) $(LDFLAGS) -o $@ $^ +xlintstrfc: $(CLINTSTRFP) $(TMGLIB) $(VARLIB) $(LAPACKLIB) $(BLASLIB) + $(FC) $(FFLAGS) $(LDFLAGS) -o $@ $^ -xlintstrfz: $(ZLINTSTRFP) $(TMGLIB) $(VARLIB) ../$(LAPACKLIB) $(BLASLIB) - $(LOADER) $(FFLAGS) $(LDFLAGS) -o $@ $^ +xlintstrfz: $(ZLINTSTRFP) $(TMGLIB) $(VARLIB) $(LAPACKLIB) $(BLASLIB) + $(FC) $(FFLAGS) $(LDFLAGS) -o $@ $^ $(ALINTST): $(FRC) $(SCLNTST): $(FRC) diff --git a/lapack-netlib/TESTING/LIN/alaerh.f b/lapack-netlib/TESTING/LIN/alaerh.f index 1845888a6..6c8a47f1e 100644 --- a/lapack-netlib/TESTING/LIN/alaerh.f +++ b/lapack-netlib/TESTING/LIN/alaerh.f @@ -797,6 +797,18 @@ WRITE( NOUT, FMT = 9978 ) $ SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, M, N, IMAT END IF +* + ELSE IF( LSAMEN( 2, P2, 'QK' ) ) THEN +* +* xQK: truncated QR factorization with pivoting +* + IF( LSAMEN( 7, SUBNAM( 2: 8 ), 'GEQP3RK' ) ) THEN + WRITE( NOUT, FMT = 9930 ) + $ SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, M, N, KL, N5, IMAT + ELSE IF( LSAMEN( 5, SUBNAM( 2: 6 ), 'LATMS' ) ) THEN + WRITE( NOUT, FMT = 9978 ) + $ SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, M, N, IMAT + END IF * ELSE IF( LSAMEN( 2, P2, 'LQ' ) ) THEN * @@ -1147,6 +1159,11 @@ * What we do next * 9949 FORMAT( ' ==> Doing only the condition estimate for this case' ) +* +* SUBNAM, INFO, M, N, NB, IMAT +* + 9930 FORMAT( ' *** Error code from ', A, '=', I5, / ' ==> M =', I5, + $ ', N =', I5, ', NX =', I5, ', NB =', I4, ', type ', I2 ) * RETURN * diff --git a/lapack-netlib/TESTING/LIN/alahd.f b/lapack-netlib/TESTING/LIN/alahd.f index dd75394b3..8f966c584 100644 --- a/lapack-netlib/TESTING/LIN/alahd.f +++ b/lapack-netlib/TESTING/LIN/alahd.f @@ -584,13 +584,27 @@ * * QR decomposition with column pivoting * - WRITE( IOUNIT, FMT = 9986 )PATH + WRITE( IOUNIT, FMT = 8006 )PATH WRITE( IOUNIT, FMT = 9969 ) WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' ) WRITE( IOUNIT, FMT = 9940 )1 WRITE( IOUNIT, FMT = 9939 )2 WRITE( IOUNIT, FMT = 9938 )3 WRITE( IOUNIT, FMT = '( '' Messages:'' )' ) +* + ELSE IF( LSAMEN( 2, P2, 'QK' ) ) THEN +* +* truncated QR decomposition with column pivoting +* + WRITE( IOUNIT, FMT = 8006 )PATH + WRITE( IOUNIT, FMT = 9871 ) + WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' ) + WRITE( IOUNIT, FMT = 8060 )1 + WRITE( IOUNIT, FMT = 8061 )2 + WRITE( IOUNIT, FMT = 8062 )3 + WRITE( IOUNIT, FMT = 8063 )4 + WRITE( IOUNIT, FMT = 8064 )5 + WRITE( IOUNIT, FMT = '( '' Messages:'' )' ) * ELSE IF( LSAMEN( 2, P2, 'TZ' ) ) THEN * @@ -779,6 +793,8 @@ $ 'tall-skinny or short-wide matrices' ) 8005 FORMAT( / 1X, A3, ': Householder reconstruction from TSQR', $ ' factorization output ', /,' for tall-skinny matrices.' ) + 8006 FORMAT( / 1X, A3, ': truncated QR factorization', + $ ' with column pivoting' ) * * GE matrix types * @@ -922,6 +938,36 @@ $ / 4X, '3. Geometric distribution', 10X, $ '6. Every second column fixed' ) * +* QK matrix types +* + 9871 FORMAT( 4X, ' 1. Zero matrix', / + $ 4X, ' 2. Random, Diagonal, CNDNUM = 2', / + $ 4X, ' 3. Random, Upper triangular, CNDNUM = 2', / + $ 4X, ' 4. Random, Lower triangular, CNDNUM = 2', / + $ 4X, ' 5. Random, First column is zero, CNDNUM = 2', / + $ 4X, ' 6. Random, Last MINMN column is zero, CNDNUM = 2', / + $ 4X, ' 7. Random, Last N column is zero, CNDNUM = 2', / + $ 4X, ' 8. Random, Middle column in MINMN is zero,', + $ ' CNDNUM = 2', / + $ 4X, ' 9. Random, First half of MINMN columns are zero,', + $ ' CNDNUM = 2', / + $ 4X, '10. Random, Last columns are zero starting from', + $ ' MINMN/2+1, CNDNUM = 2', / + $ 4X, '11. Random, Half MINMN columns in the middle are', + $ ' zero starting from MINMN/2-(MINMN/2)/2+1,' + $ ' CNDNUM = 2', / + $ 4X, '12. Random, Odd columns are ZERO, CNDNUM = 2', / + $ 4X, '13. Random, Even columns are ZERO, CNDNUM = 2', / + $ 4X, '14. Random, CNDNUM = 2', / + $ 4X, '15. Random, CNDNUM = sqrt(0.1/EPS)', / + $ 4X, '16. Random, CNDNUM = 0.1/EPS', / + $ 4X, '17. Random, CNDNUM = 0.1/EPS,', + $ ' one small singular value S(N)=1/CNDNUM', / + $ 4X, '18. Random, CNDNUM = 2, scaled near underflow,', + $ ' NORM = SMALL = SAFMIN', / + $ 4X, '19. Random, CNDNUM = 2, scaled near overflow,', + $ ' NORM = LARGE = 1.0/( 0.25 * ( SAFMIN / EPS ) )' ) +* * TZ matrix types * 9968 FORMAT( ' Matrix types (2-3 have condition 1/EPS):', / 4X, @@ -1030,9 +1076,8 @@ $ ' * norm(C) * EPS )' ) 9940 FORMAT( 3X, I2, ': norm(svd(A) - svd(R)) / ', $ '( M * norm(svd(R)) * EPS )' ) - 9939 FORMAT( 3X, I2, ': norm( A*P - Q*R ) / ( M * norm(A) * EPS )' - $ ) - 9938 FORMAT( 3X, I2, ': norm( I - Q''*Q ) / ( M * EPS )' ) + 9939 FORMAT( 3X, I2, ': norm( A*P - Q*R ) / ( M * norm(A) * EPS )') + 9938 FORMAT( 3X, I2, ': norm( I - Q''*Q ) / ( M * EPS )' ) 9937 FORMAT( 3X, I2, ': norm( A - R*Q ) / ( M * norm(A) * EPS )' $ ) 9935 FORMAT( 3X, I2, ': norm( B - A * X ) / ', @@ -1105,6 +1150,15 @@ 8054 FORMAT(3X,I2,': norm( C*Q - C*Q ) / ( M * norm(C) * EPS )' ) 8055 FORMAT(3X,I2,': norm( C*Q'' - C*Q'' ) / ( M * norm(C) * EPS )') + 8060 FORMAT( 3X, I2, ': 2-norm(svd(A) - svd(R)) / ', + $ '( max(M,N) * 2-norm(svd(R)) * EPS )' ) + 8061 FORMAT( 3X, I2, ': 1-norm( A*P - Q*R ) / ( max(M,N) * 1-norm(A)', + $ ' * EPS )') + 8062 FORMAT( 3X, I2, ': 1-norm( I - Q''*Q ) / ( M * EPS )' ) + 8063 FORMAT( 3X, I2, ': Returns 1.0D+100, if abs(R(K+1,K+1))', + $ ' > abs(R(K,K)), where K=1:KFACT-1' ) + 8064 FORMAT( 3X, I2, ': 1-norm(Q**T * B - Q**T * B ) / ( M * EPS )') + * RETURN * diff --git a/lapack-netlib/TESTING/LIN/alareq.f b/lapack-netlib/TESTING/LIN/alareq.f index db18775eb..3f057fa48 100644 --- a/lapack-netlib/TESTING/LIN/alareq.f +++ b/lapack-netlib/TESTING/LIN/alareq.f @@ -28,12 +28,12 @@ *> to evaluate the input line which requested NMATS matrix types for *> PATH. The flow of control is as follows: *> -*> If NMATS = NTYPES then +*> IF NMATS = NTYPES THEN *> DOTYPE(1:NTYPES) = .TRUE. -*> else +*> ELSE *> Read the next input line for NMATS matrix types *> Set DOTYPE(I) = .TRUE. for each valid type I -*> endif +*> END IF *> \endverbatim * * Arguments: diff --git a/lapack-netlib/TESTING/LIN/cchkaa.F b/lapack-netlib/TESTING/LIN/cchkaa.F index ec1534ed4..474454a51 100644 --- a/lapack-netlib/TESTING/LIN/cchkaa.F +++ b/lapack-netlib/TESTING/LIN/cchkaa.F @@ -69,6 +69,7 @@ *> CLQ 8 List types on next line if 0 < NTYPES < 8 *> CQL 8 List types on next line if 0 < NTYPES < 8 *> CQP 6 List types on next line if 0 < NTYPES < 6 +*> ZQK 19 List types on next line if 0 < NTYPES < 19 *> CTZ 3 List types on next line if 0 < NTYPES < 3 *> CLS 6 List types on next line if 0 < NTYPES < 6 *> CEQ @@ -153,12 +154,11 @@ $ NBVAL( MAXIN ), NBVAL2( MAXIN ), $ NSVAL( MAXIN ), NVAL( MAXIN ), NXVAL( MAXIN ), $ RANKVAL( MAXIN ), PIV( NMAX ) - REAL S( 2*NMAX ) - COMPLEX E( NMAX ) * .. * .. Allocatable Arrays .. INTEGER AllocateStatus - REAL, DIMENSION(:), ALLOCATABLE :: RWORK + REAL, DIMENSION(:), ALLOCATABLE :: RWORK, S + COMPLEX, DIMENSION(:), ALLOCATABLE :: E COMPLEX, DIMENSION(:,:), ALLOCATABLE :: A, B, WORK * .. * .. External Functions .. @@ -170,14 +170,14 @@ EXTERNAL ALAREQ, CCHKEQ, CCHKGB, CCHKGE, CCHKGT, CCHKHE, $ CCHKHE_ROOK, CCHKHE_RK, CCHKHE_AA, CCHKHP, $ CCHKLQ, CCHKUNHR_COL, CCHKPB, CCHKPO, CCHKPS, - $ CCHKPP, CCHKPT, CCHKQ3, CCHKQL, CCHKQR, CCHKRQ, - $ CCHKSP, CCHKSY, CCHKSY_ROOK, CCHKSY_RK, - $ CCHKSY_AA, CCHKTB, CCHKTP, CCHKTR, CCHKTZ, - $ CDRVGB, CDRVGE, CDRVGT, CDRVHE, CDRVHE_ROOK, - $ CDRVHE_RK, CDRVHE_AA, CDRVHP, CDRVLS, CDRVPB, - $ CDRVPO, CDRVPP, CDRVPT, CDRVSP, CDRVSY, - $ CDRVSY_ROOK, CDRVSY_RK, CDRVSY_AA, ILAVER, - $ CCHKQRT, CCHKQRTP + $ CCHKPP, CCHKPT, CCHKQ3, CCHKQP3RK, CCHKQL, + $ CCHKQR, CCHKRQ, CCHKSP, CCHKSY, CCHKSY_ROOK, + $ CCHKSY_RK, CCHKSY_AA, CCHKTB, CCHKTP, CCHKTR, + $ CCHKTZ, CDRVGB, CDRVGE, CDRVGT, CDRVHE, + $ CDRVHE_ROOK, CDRVHE_RK, CDRVHE_AA, CDRVHP, + $ CDRVLS, CDRVPB, CDRVPO, CDRVPP, CDRVPT, CDRVSP, + $ CDRVSY, CDRVSY_ROOK, CDRVSY_RK, CDRVSY_AA, + $ ILAVER, CCHKQRT, CCHKQRTP * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -203,6 +203,10 @@ IF (AllocateStatus /= 0) STOP "*** Not enough memory ***" ALLOCATE ( WORK( NMAX, NMAX+MAXRHS+10 ), STAT = AllocateStatus ) IF (AllocateStatus /= 0) STOP "*** Not enough memory ***" + ALLOCATE ( E( NMAX ), STAT = AllocateStatus ) + IF (AllocateStatus /= 0) STOP "*** Not enough memory ***" + ALLOCATE ( S( 2*NMAX ), STAT = AllocateStatus) + IF (AllocateStatus /= 0) STOP "*** Not enough memory ***" ALLOCATE ( RWORK( 150*NMAX+2*MAXRHS ), STAT = AllocateStatus ) IF (AllocateStatus /= 0) STOP "*** Not enough memory ***" * .. @@ -1109,6 +1113,23 @@ ELSE WRITE( NOUT, FMT = 9989 )PATH END IF +* + ELSE IF( LSAMEN( 2, C2, 'QK' ) ) THEN +* +* QK: truncated QR factorization with pivoting +* + NTYPES = 19 + CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) +* + IF( TSTCHK ) THEN + CALL CCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, + $ NNB, NBVAL, NXVAL, THRESH, A( 1, 1 ), + $ A( 1, 2 ), B( 1, 1 ), B( 1, 2 ), + $ S( 1 ), B( 1, 4 ), + $ WORK, RWORK, IWORK, NOUT ) + ELSE + WRITE( NOUT, FMT = 9989 )PATH + END IF * ELSE IF( LSAMEN( 2, C2, 'LS' ) ) THEN * diff --git a/lapack-netlib/TESTING/LIN/cchkqp3rk.f b/lapack-netlib/TESTING/LIN/cchkqp3rk.f new file mode 100644 index 000000000..79d6add72 --- /dev/null +++ b/lapack-netlib/TESTING/LIN/cchkqp3rk.f @@ -0,0 +1,836 @@ +*> \brief \b CCHKQP3RK +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, +* $ NNB, NBVAL, NXVAL, THRESH, A, COPYA, +* $ B, COPYB, S, TAU, +* $ WORK, RWORK, IWORK, NOUT ) +* IMPLICIT NONE +* +* .. Scalar Arguments .. +* INTEGER NM, NN, NNB, NOUT +* REAL THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER IWORK( * ), MVAL( * ), NBVAL( * ), NVAL( * ), +* $ NXVAL( * ) +* REAL S( * ), RWORK( * ) +* COMPLEX A( * ), COPYA( * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CCHKQP3RK tests CGEQP3RK. +*> \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] NM +*> \verbatim +*> NM is INTEGER +*> The number of values of M contained in the vector MVAL. +*> \endverbatim +*> +*> \param[in] MVAL +*> \verbatim +*> MVAL is INTEGER array, dimension (NM) +*> The values of the matrix row dimension M. +*> \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 column dimension N. +*> \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] NNB +*> \verbatim +*> NNB is INTEGER +*> The number of values of NB and NX contained in the +*> vectors NBVAL and NXVAL. The blocking parameters are used +*> in pairs (NB,NX). +*> \endverbatim +*> +*> \param[in] NBVAL +*> \verbatim +*> NBVAL is INTEGER array, dimension (NNB) +*> The values of the blocksize NB. +*> \endverbatim +*> +*> \param[in] NXVAL +*> \verbatim +*> NXVAL is INTEGER array, dimension (NNB) +*> The values of the crossover point NX. +*> \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[out] A +*> \verbatim +*> A is COMPLEX array, dimension (MMAX*NMAX) +*> where MMAX is the maximum value of M in MVAL and NMAX is the +*> maximum value of N in NVAL. +*> \endverbatim +*> +*> \param[out] COPYA +*> \verbatim +*> COPYA is COMPLEX array, dimension (MMAX*NMAX) +*> \endverbatim +*> +*> \param[out] B +*> \verbatim +*> B is COMPLEX array, dimension (MMAX*NSMAX) +*> where MMAX is the maximum value of M in MVAL and NSMAX is the +*> maximum value of NRHS in NSVAL. +*> \endverbatim +*> +*> \param[out] COPYB +*> \verbatim +*> COPYB is COMPLEX array, dimension (MMAX*NSMAX) +*> \endverbatim +*> +*> \param[out] S +*> \verbatim +*> S is REAL array, dimension +*> (min(MMAX,NMAX)) +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is COMPLEX array, dimension (MMAX) +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX array, dimension +*> (max(M*max(M,N) + 4*min(M,N) + max(M,N))) +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is REAL array, dimension (4*NMAX) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (2*NMAX) +*> \endverbatim +*> +*> \param[in] NOUT +*> \verbatim +*> NOUT is INTEGER +*> The unit number for output. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup complex_lin +* +* ===================================================================== + SUBROUTINE CCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, + $ NNB, NBVAL, NXVAL, THRESH, A, COPYA, + $ B, COPYB, S, TAU, + $ WORK, RWORK, IWORK, NOUT ) + IMPLICIT NONE +* +* -- LAPACK test routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER NM, NN, NNB, NNS, NOUT + REAL THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER IWORK( * ), NBVAL( * ), MVAL( * ), NVAL( * ), + $ NSVAL( * ), NXVAL( * ) + REAL S( * ), RWORK( * ) + COMPLEX A( * ), COPYA( * ), B( * ), COPYB( * ), + $ TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER NTYPES + PARAMETER ( NTYPES = 19 ) + INTEGER NTESTS + PARAMETER ( NTESTS = 5 ) + REAL ONE, ZERO, BIGNUM + COMPLEX CONE, CZERO + PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0, + $ CZERO = ( 0.0E+0, 0.0E+0 ), + $ CONE = ( 1.0E+0, 0.0E+0 ), + $ BIGNUM = 1.0E+38 ) +* .. +* .. Local Scalars .. + CHARACTER DIST, TYPE + CHARACTER*3 PATH + INTEGER I, IHIGH, ILOW, IM, IMAT, IN, INC_ZERO, + $ INB, IND_OFFSET_GEN, + $ IND_IN, IND_OUT, INS, INFO, + $ ISTEP, J, J_INC, J_FIRST_NZ, JB_ZERO, + $ KFACT, KL, KMAX, KU, LDA, LW, LWORK, + $ LWORK_MQR, M, MINMN, MINMNB_GEN, MODE, N, + $ NB, NB_ZERO, NERRS, NFAIL, NB_GEN, NRHS, + $ NRUN, NX, T + REAL ANORM, CNDNUM, EPS, ABSTOL, RELTOL, + $ DTEMP, MAXC2NRMK, RELMAXC2NRMK +* .. +* .. Local Arrays .. + INTEGER ISEED( 4 ), ISEEDY( 4 ) + REAL RESULT( NTESTS ), RDUMMY( 1 ) +* .. +* .. External Functions .. + REAL SLAMCH, CQPT01, CQRT11, CQRT12, CLANGE + EXTERNAL SLAMCH, CQPT01, CQRT11, CQRT12, CLANGE +* .. +* .. External Subroutines .. + EXTERNAL ALAERH, ALAHD, ALASUM, SLAORD, ICOPY, CAXPY, + $ XLAENV, CGEQP3RK, CLACPY, CLASET, CLATB4, + $ CLATMS, CUNMQR, CSWAP +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, MOD, REAL +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, IOUNIT, CUNMQR_LWORK +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, IOUNIT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Data statements .. + DATA ISEEDY / 1988, 1989, 1990, 1991 / +* .. +* .. Executable Statements .. +* +* Initialize constants and the random number seed. +* + PATH( 1: 1 ) = 'Complex precision' + PATH( 2: 3 ) = 'QK' + NRUN = 0 + NFAIL = 0 + NERRS = 0 + DO I = 1, 4 + ISEED( I ) = ISEEDY( I ) + END DO + EPS = SLAMCH( 'Epsilon' ) + INFOT = 0 +* + DO IM = 1, NM +* +* Do for each value of M in MVAL. +* + M = MVAL( IM ) + LDA = MAX( 1, M ) +* + DO IN = 1, NN +* +* Do for each value of N in NVAL. +* + N = NVAL( IN ) + MINMN = MIN( M, N ) + LWORK = MAX( 1, M*MAX( M, N )+4*MINMN+MAX( M, N ), + $ M*N + 2*MINMN + 4*N ) +* + DO INS = 1, NNS + NRHS = NSVAL( INS ) +* +* Set up parameters with CLATB4 and generate +* M-by-NRHS B matrix with CLATMS. +* IMAT = 14: +* Random matrix, CNDNUM = 2, NORM = ONE, +* MODE = 3 (geometric distribution of singular values). +* + CALL CLATB4( PATH, 14, M, NRHS, TYPE, KL, KU, ANORM, + $ MODE, CNDNUM, DIST ) +* + SRNAMT = 'CLATMS' + CALL CLATMS( M, NRHS, DIST, ISEED, TYPE, S, MODE, + $ CNDNUM, ANORM, KL, KU, 'No packing', + $ COPYB, LDA, WORK, INFO ) +* +* Check error code from CLATMS. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'CLATMS', INFO, 0, ' ', M, + $ NRHS, -1, -1, -1, 6, NFAIL, NERRS, + $ NOUT ) + CYCLE + END IF +* + DO IMAT = 1, NTYPES +* +* Do the tests only if DOTYPE( IMAT ) is true. +* + IF( .NOT.DOTYPE( IMAT ) ) + $ CYCLE +* +* The type of distribution used to generate the random +* eigen-/singular values: +* ( 'S' for symmetric distribution ) => UNIFORM( -1, 1 ) +* +* Do for each type of NON-SYMMETRIC matrix: CNDNUM NORM MODE +* 1. Zero matrix +* 2. Random, Diagonal, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values ) +* 3. Random, Upper triangular, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values ) +* 4. Random, Lower triangular, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values ) +* 5. Random, First column is zero, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values ) +* 6. Random, Last MINMN column is zero, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values ) +* 7. Random, Last N column is zero, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values ) +* 8. Random, Middle column in MINMN is zero, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values ) +* 9. Random, First half of MINMN columns are zero, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values ) +* 10. Random, Last columns are zero starting from MINMN/2+1, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values ) +* 11. Random, Half MINMN columns in the middle are zero starting +* from MINMN/2-(MINMN/2)/2+1, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values ) +* 12. Random, Odd columns are ZERO, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values ) +* 13. Random, Even columns are ZERO, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values ) +* 14. Random, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values ) +* 15. Random, CNDNUM = sqrt(0.1/EPS) CNDNUM = BADC1 = sqrt(0.1/EPS) ONE 3 ( geometric distribution of singular values ) +* 16. Random, CNDNUM = 0.1/EPS CNDNUM = BADC2 = 0.1/EPS ONE 3 ( geometric distribution of singular values ) +* 17. Random, CNDNUM = 0.1/EPS, CNDNUM = BADC2 = 0.1/EPS ONE 2 ( one small singular value, S(N)=1/CNDNUM ) +* one small singular value S(N)=1/CNDNUM +* 18. Random, CNDNUM = 2, scaled near underflow CNDNUM = 2 SMALL = SAFMIN +* 19. Random, CNDNUM = 2, scaled near overflow CNDNUM = 2 LARGE = 1.0/( 0.25 * ( SAFMIN / EPS ) ) 3 ( geometric distribution of singular values ) +* + IF( IMAT.EQ.1 ) THEN +* +* Matrix 1: Zero matrix +* + CALL CLASET( 'Full', M, N, CZERO, CZERO, COPYA, LDA ) + DO I = 1, MINMN + S( I ) = ZERO + END DO +* + ELSE IF( (IMAT.GE.2 .AND. IMAT.LE.4 ) + $ .OR. (IMAT.GE.14 .AND. IMAT.LE.19 ) ) THEN +* +* Matrices 2-5. +* +* Set up parameters with DLATB4 and generate a test +* matrix with CLATMS. +* + CALL CLATB4( PATH, IMAT, M, N, TYPE, KL, KU, ANORM, + $ MODE, CNDNUM, DIST ) +* + SRNAMT = 'CLATMS' + CALL CLATMS( M, N, DIST, ISEED, TYPE, S, MODE, + $ CNDNUM, ANORM, KL, KU, 'No packing', + $ COPYA, LDA, WORK, INFO ) +* +* Check error code from CLATMS. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'CLATMS', INFO, 0, ' ', M, N, + $ -1, -1, -1, IMAT, NFAIL, NERRS, + $ NOUT ) + CYCLE + END IF +* + CALL SLAORD( 'Decreasing', MINMN, S, 1 ) +* + ELSE IF( MINMN.GE.2 + $ .AND. IMAT.GE.5 .AND. IMAT.LE.13 ) THEN +* +* Rectangular matrices 5-13 that contain zero columns, +* only for matrices MINMN >=2. +* +* JB_ZERO is the column index of ZERO block. +* NB_ZERO is the column block size of ZERO block. +* NB_GEN is the column blcok size of the +* generated block. +* J_INC in the non_zero column index increment +* for matrix 12 and 13. +* J_FIRS_NZ is the index of the first non-zero +* column. +* + IF( IMAT.EQ.5 ) THEN +* +* First column is zero. +* + JB_ZERO = 1 + NB_ZERO = 1 + NB_GEN = N - NB_ZERO +* + ELSE IF( IMAT.EQ.6 ) THEN +* +* Last column MINMN is zero. +* + JB_ZERO = MINMN + NB_ZERO = 1 + NB_GEN = N - NB_ZERO +* + ELSE IF( IMAT.EQ.7 ) THEN +* +* Last column N is zero. +* + JB_ZERO = N + NB_ZERO = 1 + NB_GEN = N - NB_ZERO +* + ELSE IF( IMAT.EQ.8 ) THEN +* +* Middle column in MINMN is zero. +* + JB_ZERO = MINMN / 2 + 1 + NB_ZERO = 1 + NB_GEN = N - NB_ZERO +* + ELSE IF( IMAT.EQ.9 ) THEN +* +* First half of MINMN columns is zero. +* + JB_ZERO = 1 + NB_ZERO = MINMN / 2 + NB_GEN = N - NB_ZERO +* + ELSE IF( IMAT.EQ.10 ) THEN +* +* Last columns are zero columns, +* starting from (MINMN / 2 + 1) column. +* + JB_ZERO = MINMN / 2 + 1 + NB_ZERO = N - JB_ZERO + 1 + NB_GEN = N - NB_ZERO +* + ELSE IF( IMAT.EQ.11 ) THEN +* +* Half of the columns in the middle of MINMN +* columns is zero, starting from +* MINMN/2 - (MINMN/2)/2 + 1 column. +* + JB_ZERO = MINMN / 2 - (MINMN / 2) / 2 + 1 + NB_ZERO = MINMN / 2 + NB_GEN = N - NB_ZERO +* + ELSE IF( IMAT.EQ.12 ) THEN +* +* Odd-numbered columns are zero, +* + NB_GEN = N / 2 + NB_ZERO = N - NB_GEN + J_INC = 2 + J_FIRST_NZ = 2 +* + ELSE IF( IMAT.EQ.13 ) THEN +* +* Even-numbered columns are zero. +* + NB_ZERO = N / 2 + NB_GEN = N - NB_ZERO + J_INC = 2 + J_FIRST_NZ = 1 +* + END IF +* +* +* 1) Set the first NB_ZERO columns in COPYA(1:M,1:N) +* to zero. +* + CALL CLASET( 'Full', M, NB_ZERO, CZERO, CZERO, + $ COPYA, LDA ) +* +* 2) Generate an M-by-(N-NB_ZERO) matrix with the +* chosen singular value distribution +* in COPYA(1:M,NB_ZERO+1:N). +* + CALL CLATB4( PATH, IMAT, M, NB_GEN, TYPE, KL, KU, + $ ANORM, MODE, CNDNUM, DIST ) +* + SRNAMT = 'CLATMS' +* + IND_OFFSET_GEN = NB_ZERO * LDA +* + CALL CLATMS( M, NB_GEN, DIST, ISEED, TYPE, S, MODE, + $ CNDNUM, ANORM, KL, KU, 'No packing', + $ COPYA( IND_OFFSET_GEN + 1 ), LDA, + $ WORK, INFO ) +* +* Check error code from CLATMS. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'CLATMS', INFO, 0, ' ', M, + $ NB_GEN, -1, -1, -1, IMAT, NFAIL, + $ NERRS, NOUT ) + CYCLE + END IF +* +* 3) Swap the gererated colums from the right side +* NB_GEN-size block in COPYA into correct column +* positions. +* + IF( IMAT.EQ.6 + $ .OR. IMAT.EQ.7 + $ .OR. IMAT.EQ.8 + $ .OR. IMAT.EQ.10 + $ .OR. IMAT.EQ.11 ) THEN +* +* Move by swapping the generated columns +* from the right NB_GEN-size block from +* (NB_ZERO+1:NB_ZERO+JB_ZERO) +* into columns (1:JB_ZERO-1). +* + DO J = 1, JB_ZERO-1, 1 + CALL CSWAP( M, + $ COPYA( ( NB_ZERO+J-1)*LDA+1), 1, + $ COPYA( (J-1)*LDA + 1 ), 1 ) + END DO +* + ELSE IF( IMAT.EQ.12 .OR. IMAT.EQ.13 ) THEN +* +* ( IMAT = 12, Odd-numbered ZERO columns. ) +* Swap the generated columns from the right +* NB_GEN-size block into the even zero colums in the +* left NB_ZERO-size block. +* +* ( IMAT = 13, Even-numbered ZERO columns. ) +* Swap the generated columns from the right +* NB_GEN-size block into the odd zero colums in the +* left NB_ZERO-size block. +* + DO J = 1, NB_GEN, 1 + IND_OUT = ( NB_ZERO+J-1 )*LDA + 1 + IND_IN = ( J_INC*(J-1)+(J_FIRST_NZ-1) )*LDA + $ + 1 + CALL CSWAP( M, + $ COPYA( IND_OUT ), 1, + $ COPYA( IND_IN), 1 ) + END DO +* + END IF +* +* 5) Order the singular values generated by +* DLAMTS in decreasing order and add trailing zeros +* that correspond to zero columns. +* The total number of singular values is MINMN. +* + MINMNB_GEN = MIN( M, NB_GEN ) +* + CALL SLAORD( 'Decreasing', MINMNB_GEN, S, 1 ) + + DO I = MINMNB_GEN+1, MINMN + S( I ) = ZERO + END DO +* + ELSE +* +* IF(MINMN.LT.2) skip this size for this matrix type. +* + CYCLE + END IF +* +* Initialize a copy array for a pivot array for DGEQP3RK. +* + DO I = 1, N + IWORK( I ) = 0 + END DO +* + DO INB = 1, NNB +* +* Do for each pair of values (NB,NX) in NBVAL and NXVAL. +* + NB = NBVAL( INB ) + CALL XLAENV( 1, NB ) + NX = NXVAL( INB ) + CALL XLAENV( 3, NX ) +* +* We do MIN(M,N)+1 because we need a test for KMAX > N, +* when KMAX is larger than MIN(M,N), KMAX should be +* KMAX = MIN(M,N) +* + DO KMAX = 0, MIN(M,N)+1 +* +* Get a working copy of COPYA into A( 1:M,1:N ). +* Get a working copy of COPYB into A( 1:M, (N+1):NRHS ). +* Get a working copy of COPYB into into B( 1:M, 1:NRHS ). +* Get a working copy of IWORK(1:N) awith zeroes into +* which is going to be used as pivot array IWORK( N+1:2N ). +* NOTE: IWORK(2N+1:3N) is going to be used as a WORK array +* for the routine. +* + CALL CLACPY( 'All', M, N, COPYA, LDA, A, LDA ) + CALL CLACPY( 'All', M, NRHS, COPYB, LDA, + $ A( LDA*N + 1 ), LDA ) + CALL CLACPY( 'All', M, NRHS, COPYB, LDA, + $ B, LDA ) + CALL ICOPY( N, IWORK( 1 ), 1, IWORK( N+1 ), 1 ) +* + ABSTOL = -1.0 + RELTOl = -1.0 +* +* Compute the QR factorization with pivoting of A +* + LW = MAX( 1, MAX( 2*N + NB*( N+NRHS+1 ), + $ 3*N + NRHS - 1 ) ) +* +* Compute CGEQP3RK factorization of A. +* + SRNAMT = 'CGEQP3RK' + CALL CGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, + $ A, LDA, KFACT, MAXC2NRMK, + $ RELMAXC2NRMK, IWORK( N+1 ), TAU, + $ WORK, LW, RWORK, IWORK( 2*N+1 ), + $ INFO ) +* +* Check error code from CGEQP3RK. +* + IF( INFO.LT.0 ) + $ CALL ALAERH( PATH, 'CGEQP3RK', INFO, 0, ' ', + $ M, N, NX, -1, NB, IMAT, + $ NFAIL, NERRS, NOUT ) +* + IF( KFACT.EQ.MINMN ) THEN +* +* Compute test 1: +* +* This test in only for the full rank factorization of +* the matrix A. +* +* Array S(1:min(M,N)) contains svd(A) the sigular values +* of the original matrix A in decreasing absolute value +* order. The test computes svd(R), the vector sigular +* values of the upper trapezoid of A(1:M,1:N) that +* contains the factor R, in decreasing order. The test +* returns the ratio: +* +* 2-norm(svd(R) - svd(A)) / ( max(M,N) * 2-norm(svd(A)) * EPS ) +* + RESULT( 1 ) = CQRT12( M, N, A, LDA, S, WORK, + $ LWORK , RWORK ) +* + DO T = 1, 1 + IF( RESULT( T ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 ) 'CGEQP3RK', M, N, + $ NRHS, KMAX, ABSTOL, RELTOL, NB, NX, + $ IMAT, T, RESULT( T ) + NFAIL = NFAIL + 1 + END IF + END DO + NRUN = NRUN + 1 +* +* End test 1 +* + END IF + +* Compute test 2: +* +* The test returns the ratio: +* +* 1-norm( A*P - Q*R ) / ( max(M,N) * 1-norm(A) * EPS ) +* + RESULT( 2 ) = CQPT01( M, N, KFACT, COPYA, A, LDA, TAU, + $ IWORK( N+1 ), WORK, LWORK ) +* +* Compute test 3: +* +* The test returns the ratio: +* +* 1-norm( Q**T * Q - I ) / ( M * EPS ) +* + RESULT( 3 ) = CQRT11( M, KFACT, A, LDA, TAU, WORK, + $ LWORK ) +* +* Print information about the tests that did not pass +* the threshold. +* + DO T = 2, 3 + IF( RESULT( T ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 ) 'CGEQP3RK', M, N, + $ NRHS, KMAX, ABSTOL, RELTOL, + $ NB, NX, IMAT, T, RESULT( T ) + NFAIL = NFAIL + 1 + END IF + END DO + NRUN = NRUN + 2 +* +* Compute test 4: +* +* This test is only for the factorizations with the +* rank greater than 2. +* The elements on the diagonal of R should be non- +* increasing. +* +* The test returns the ratio: +* +* Returns 1.0D+100 if abs(R(K+1,K+1)) > abs(R(K,K)), +* K=1:KFACT-1 +* + IF( MIN(KFACT, MINMN).GE.2 ) THEN +* + DO J = 1, KFACT-1, 1 +* + DTEMP = (( ABS( A( (J-1)*M+J ) ) - + $ ABS( A( (J)*M+J+1 ) ) ) / + $ ABS( A(1) ) ) +* + IF( DTEMP.LT.ZERO ) THEN + RESULT( 4 ) = BIGNUM + END IF +* + END DO +* +* Print information about the tests that did not +* pass the threshold. +* + DO T = 4, 4 + IF( RESULT( T ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 ) 'CGEQP3RK', + $ M, N, NRHS, KMAX, ABSTOL, RELTOL, + $ NB, NX, IMAT, T, + $ RESULT( T ) + NFAIL = NFAIL + 1 + END IF + END DO + NRUN = NRUN + 1 +* +* End test 4. +* + END IF +* +* Compute test 5: +* +* This test in only for matrix A with min(M,N) > 0. +* +* The test returns the ratio: +* +* 1-norm(Q**T * B - Q**T * B ) / +* ( M * EPS ) +* +* (1) Compute B:=Q**T * B in the matrix B. +* + IF( MINMN.GT.0 ) THEN +* + LWORK_MQR = MAX(1, NRHS) + CALL CUNMQR( 'Left', 'Conjugate transpose', + $ M, NRHS, KFACT, A, LDA, TAU, B, LDA, + $ WORK, LWORK_MQR, INFO ) +* + DO I = 1, NRHS +* +* Compare N+J-th column of A and J-column of B. +* + CALL CAXPY( M, -CONE, A( ( N+I-1 )*LDA+1 ), 1, + $ B( ( I-1 )*LDA+1 ), 1 ) + END DO +* + RESULT( 5 ) = + $ ABS( + $ CLANGE( 'One-norm', M, NRHS, B, LDA, RDUMMY ) / + $ ( REAL( M )*SLAMCH( 'Epsilon' ) ) + $ ) +* +* Print information about the tests that did not pass +* the threshold. +* + DO T = 5, 5 + IF( RESULT( T ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 ) 'CGEQP3RK', M, N, + $ NRHS, KMAX, ABSTOL, RELTOL, + $ NB, NX, IMAT, T, RESULT( T ) + NFAIL = NFAIL + 1 + END IF + END DO + NRUN = NRUN + 1 +* +* End compute test 5. +* + END IF +* +* END DO KMAX = 1, MIN(M,N)+1 +* + END DO +* +* END DO for INB = 1, NNB +* + END DO +* +* END DO for IMAT = 1, NTYPES +* + END DO +* +* END DO for INS = 1, NNS +* + END DO +* +* END DO for IN = 1, NN +* + END DO +* +* END DO for IM = 1, NM +* + END DO +* +* Print a summary of the results. +* + CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) +* + 9999 FORMAT( 1X, A, ' M =', I5, ', N =', I5, ', NRHS =', I5, + $ ', KMAX =', I5, ', ABSTOL =', G12.5, + $ ', RELTOL =', G12.5, ', NB =', I4, ', NX =', I4, + $ ', type ', I2, ', test ', I2, ', ratio =', G12.5 ) +* +* End of CCHKQP3RK +* + END diff --git a/lapack-netlib/TESTING/LIN/clatb4.f b/lapack-netlib/TESTING/LIN/clatb4.f index eeb0f03a9..233a8631a 100644 --- a/lapack-netlib/TESTING/LIN/clatb4.f +++ b/lapack-netlib/TESTING/LIN/clatb4.f @@ -154,9 +154,6 @@ * .. Intrinsic Functions .. INTRINSIC ABS, MAX, SQRT * .. -* .. External Subroutines .. - EXTERNAL SLABAD -* .. * .. Save statement .. SAVE EPS, SMALL, LARGE, BADC1, BADC2, FIRST * .. @@ -174,11 +171,6 @@ BADC1 = SQRT( BADC2 ) SMALL = SLAMCH( 'Safe minimum' ) LARGE = ONE / SMALL -* -* If it looks like we're on a Cray, take the square root of -* SMALL and LARGE to avoid overflow and underflow problems. -* - CALL SLABAD( SMALL, LARGE ) SMALL = SHRINK*( SMALL / EPS ) LARGE = ONE / SMALL END IF @@ -233,6 +225,110 @@ ELSE ANORM = ONE END IF +* + ELSE IF( LSAMEN( 2, C2, 'QK' ) ) THEN +* +* xQK: truncated QR with pivoting. +* Set parameters to generate a general +* M x N matrix. +* +* Set TYPE, the type of matrix to be generated. 'N' is nonsymmetric. +* + TYPE = 'N' +* +* Set DIST, the type of distribution for the random +* number generator. 'S' is +* + DIST = 'S' +* +* Set the lower and upper bandwidths. +* + IF( IMAT.EQ.2 ) THEN +* +* 2. Random, Diagonal, CNDNUM = 2 +* + KL = 0 + KU = 0 + CNDNUM = TWO + ANORM = ONE + MODE = 3 + ELSE IF( IMAT.EQ.3 ) THEN +* +* 3. Random, Upper triangular, CNDNUM = 2 +* + KL = 0 + KU = MAX( N-1, 0 ) + CNDNUM = TWO + ANORM = ONE + MODE = 3 + ELSE IF( IMAT.EQ.4 ) THEN +* +* 4. Random, Lower triangular, CNDNUM = 2 +* + KL = MAX( M-1, 0 ) + KU = 0 + CNDNUM = TWO + ANORM = ONE + MODE = 3 + ELSE +* +* 5.-19. Rectangular matrix +* + KL = MAX( M-1, 0 ) + KU = MAX( N-1, 0 ) +* + IF( IMAT.GE.5 .AND. IMAT.LE.14 ) THEN +* +* 5.-14. Random, CNDNUM = 2. +* + CNDNUM = TWO + ANORM = ONE + MODE = 3 +* + ELSE IF( IMAT.EQ.15 ) THEN +* +* 15. Random, CNDNUM = sqrt(0.1/EPS) +* + CNDNUM = BADC1 + ANORM = ONE + MODE = 3 +* + ELSE IF( IMAT.EQ.16 ) THEN +* +* 16. Random, CNDNUM = 0.1/EPS +* + CNDNUM = BADC2 + ANORM = ONE + MODE = 3 +* + ELSE IF( IMAT.EQ.17 ) THEN +* +* 17. Random, CNDNUM = 0.1/EPS, +* one small singular value S(N)=1/CNDNUM +* + CNDNUM = BADC2 + ANORM = ONE + MODE = 2 +* + ELSE IF( IMAT.EQ.18 ) THEN +* +* 18. Random, scaled near underflow +* + CNDNUM = TWO + ANORM = SMALL + MODE = 3 +* + ELSE IF( IMAT.EQ.19 ) THEN +* +* 19. Random, scaled near overflow +* + CNDNUM = TWO + ANORM = LARGE + MODE = 3 +* + END IF +* + END IF * ELSE IF( LSAMEN( 2, C2, 'GE' ) ) THEN * @@ -517,17 +613,18 @@ * * Set the norm and condition number. * - IF( IMAT.EQ.2 .OR. IMAT.EQ.8 ) THEN + MAT = ABS( IMAT ) + IF( MAT.EQ.2 .OR. MAT.EQ.8 ) THEN CNDNUM = BADC1 - ELSE IF( IMAT.EQ.3 .OR. IMAT.EQ.9 ) THEN + ELSE IF( MAT.EQ.3 .OR. MAT.EQ.9 ) THEN CNDNUM = BADC2 ELSE CNDNUM = TWO END IF * - IF( IMAT.EQ.4 ) THEN + IF( MAT.EQ.4 ) THEN ANORM = SMALL - ELSE IF( IMAT.EQ.5 ) THEN + ELSE IF( MAT.EQ.5 ) THEN ANORM = LARGE ELSE ANORM = ONE diff --git a/lapack-netlib/TESTING/LIN/cqpt01.f b/lapack-netlib/TESTING/LIN/cqpt01.f index 79fc2dc66..149c5bb7c 100644 --- a/lapack-netlib/TESTING/LIN/cqpt01.f +++ b/lapack-netlib/TESTING/LIN/cqpt01.f @@ -33,7 +33,8 @@ *> Householder vectors, and the rest of AF contains a partially updated *> matrix. *> -*> This function returns ||A*P - Q*R||/(||norm(A)||*eps*M) +*> This function returns ||A*P - Q*R|| / ( ||norm(A)||*eps*max(M,N) ) +*> where || . || is matrix one norm. *> \endverbatim * * Arguments: @@ -172,28 +173,28 @@ * NORMA = CLANGE( 'One-norm', M, N, A, LDA, RWORK ) * - DO 30 J = 1, K - DO 10 I = 1, MIN( J, M ) + DO J = 1, K + DO I = 1, MIN( J, M ) WORK( ( J-1 )*M+I ) = AF( I, J ) - 10 CONTINUE - DO 20 I = J + 1, M + END DO + DO I = J + 1, M WORK( ( J-1 )*M+I ) = ZERO - 20 CONTINUE - 30 CONTINUE - DO 40 J = K + 1, N + END DO + END DO + DO J = K + 1, N CALL CCOPY( M, AF( 1, J ), 1, WORK( ( J-1 )*M+1 ), 1 ) - 40 CONTINUE + END DO * CALL CUNMQR( 'Left', 'No transpose', M, N, K, AF, LDA, TAU, WORK, $ M, WORK( M*N+1 ), LWORK-M*N, INFO ) * - DO 50 J = 1, N + DO J = 1, N * * Compare i-th column of QR and jpvt(i)-th column of A * CALL CAXPY( M, CMPLX( -ONE ), A( 1, JPVT( J ) ), 1, $ WORK( ( J-1 )*M+1 ), 1 ) - 50 CONTINUE + END DO * CQPT01 = CLANGE( 'One-norm', M, N, WORK, M, RWORK ) / $ ( REAL( MAX( M, N ) )*SLAMCH( 'Epsilon' ) ) diff --git a/lapack-netlib/TESTING/LIN/cqrt11.f b/lapack-netlib/TESTING/LIN/cqrt11.f index 494d5e9cd..a52084973 100644 --- a/lapack-netlib/TESTING/LIN/cqrt11.f +++ b/lapack-netlib/TESTING/LIN/cqrt11.f @@ -157,9 +157,9 @@ CALL CUNM2R( 'Left', 'Conjugate transpose', M, M, K, A, LDA, TAU, $ WORK, M, WORK( M*M+1 ), INFO ) * - DO 10 J = 1, M + DO J = 1, M WORK( ( J-1 )*M+J ) = WORK( ( J-1 )*M+J ) - ONE - 10 CONTINUE + END DO * CQRT11 = CLANGE( 'One-norm', M, M, WORK, M, RDUMMY ) / $ ( REAL( M )*SLAMCH( 'Epsilon' ) ) diff --git a/lapack-netlib/TESTING/LIN/cqrt12.f b/lapack-netlib/TESTING/LIN/cqrt12.f index 4c29423ae..0df2d833b 100644 --- a/lapack-netlib/TESTING/LIN/cqrt12.f +++ b/lapack-netlib/TESTING/LIN/cqrt12.f @@ -28,7 +28,7 @@ *> CQRT12 computes the singular values `svlues' of the upper trapezoid *> of A(1:M,1:N) and returns the ratio *> -*> || s - svlues||/(||svlues||*eps*max(M,N)) +*> || svlues -s ||/( ||s||*eps*max(M,N) ) *> \endverbatim * * Arguments: @@ -125,8 +125,8 @@ EXTERNAL CLANGE, SASUM, SLAMCH, SNRM2 * .. * .. External Subroutines .. - EXTERNAL CGEBD2, CLASCL, CLASET, SAXPY, SBDSQR, SLABAD, - $ SLASCL, XERBLA + EXTERNAL CGEBD2, CLASCL, CLASET, SAXPY, SBDSQR, SLASCL, + $ XERBLA * .. * .. Intrinsic Functions .. INTRINSIC CMPLX, MAX, MIN, REAL @@ -153,17 +153,16 @@ * Copy upper triangle of A into work * CALL CLASET( 'Full', M, N, CMPLX( ZERO ), CMPLX( ZERO ), WORK, M ) - DO 20 J = 1, N - DO 10 I = 1, MIN( J, M ) + DO J = 1, N + DO I = 1, MIN( J, M ) WORK( ( J-1 )*M+I ) = A( I, J ) - 10 CONTINUE - 20 CONTINUE + END DO + END DO * * Get machine parameters * SMLNUM = SLAMCH( 'S' ) / SLAMCH( 'P' ) BIGNUM = ONE / SMLNUM - CALL SLABAD( SMLNUM, BIGNUM ) * * Scale work if max entry outside range [SMLNUM,BIGNUM] * @@ -207,9 +206,9 @@ * ELSE * - DO 30 I = 1, MN + DO I = 1, MN RWORK( I ) = ZERO - 30 CONTINUE + END DO END IF * * Compare s and singular values of work diff --git a/lapack-netlib/TESTING/LIN/dchkaa.F b/lapack-netlib/TESTING/LIN/dchkaa.F index ef9d7808c..74077eb94 100644 --- a/lapack-netlib/TESTING/LIN/dchkaa.F +++ b/lapack-netlib/TESTING/LIN/dchkaa.F @@ -63,6 +63,7 @@ *> DLQ 8 List types on next line if 0 < NTYPES < 8 *> DQL 8 List types on next line if 0 < NTYPES < 8 *> DQP 6 List types on next line if 0 < NTYPES < 6 +*> DQK 19 List types on next line if 0 < NTYPES < 19 *> DTZ 3 List types on next line if 0 < NTYPES < 3 *> DLS 6 List types on next line if 0 < NTYPES < 6 *> DEQ @@ -149,12 +150,12 @@ $ NBVAL( MAXIN ), NBVAL2( MAXIN ), $ NSVAL( MAXIN ), NVAL( MAXIN ), NXVAL( MAXIN ), $ RANKVAL( MAXIN ), PIV( NMAX ) - DOUBLE PRECISION E( NMAX ), S( 2*NMAX ) * .. * .. Allocatable Arrays .. INTEGER AllocateStatus - DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: RWORK - DOUBLE PRECISION, DIMENSION(:,:), ALLOCATABLE :: A, B, WORK + DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: RWORK, S + DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: E + DOUBLE PRECISION, DIMENSION(:,:), ALLOCATABLE :: A, B, WORK * .. * .. External Functions .. LOGICAL LSAME, LSAMEN @@ -164,13 +165,13 @@ * .. External Subroutines .. EXTERNAL ALAREQ, DCHKEQ, DCHKGB, DCHKGE, DCHKGT, DCHKLQ, $ DCHKORHR_COL, DCHKPB, DCHKPO, DCHKPS, DCHKPP, - $ DCHKPT, DCHKQ3, DCHKQL, DCHKQR, DCHKRQ, DCHKSP, - $ DCHKSY, DCHKSY_ROOK, DCHKSY_RK, DCHKSY_AA, - $ DCHKTB, DCHKTP, DCHKTR, DCHKTZ, DDRVGB, DDRVGE, - $ DDRVGT, DDRVLS, DDRVPB, DDRVPO, DDRVPP, DDRVPT, - $ DDRVSP, DDRVSY, DDRVSY_ROOK, DDRVSY_RK, - $ DDRVSY_AA, ILAVER, DCHKLQTP, DCHKQRT, DCHKQRTP, - $ DCHKLQT,DCHKTSQR + $ DCHKPT, DCHKQ3, DCHKQP3RK, DCHKQL, DCHKQR, + $ DCHKRQ, DCHKSP, DCHKSY, DCHKSY_ROOK, DCHKSY_RK, + $ DCHKSY_AA, DCHKTB, DCHKTP, DCHKTR, DCHKTZ, + $ DDRVGB, DDRVGE, DDRVGT, DDRVLS, DDRVPB, DDRVPO, + $ DDRVPP, DDRVPT, DDRVSP, DDRVSY, DDRVSY_ROOK, + $ DDRVSY_RK, DDRVSY_AA, ILAVER, DCHKLQTP, DCHKQRT, + $ DCHKQRTP, DCHKLQT,DCHKTSQR * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -197,6 +198,10 @@ IF (AllocateStatus /= 0) STOP "*** Not enough memory ***" ALLOCATE ( WORK( NMAX, 3*NMAX+MAXRHS+30 ), STAT = AllocateStatus ) IF (AllocateStatus /= 0) STOP "*** Not enough memory ***" + ALLOCATE ( E( NMAX ), STAT = AllocateStatus ) + IF (AllocateStatus /= 0) STOP "*** Not enough memory ***" + ALLOCATE ( S( 2*NMAX ), STAT = AllocateStatus ) + IF (AllocateStatus /= 0) STOP "*** Not enough memory ***" ALLOCATE ( RWORK( 5*NMAX+2*MAXRHS ), STAT = AllocateStatus ) IF (AllocateStatus /= 0) STOP "*** Not enough memory ***" * @@ -919,9 +924,26 @@ CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) * IF( TSTCHK ) THEN - CALL DCHKQ3( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NXVAL, - $ THRESH, A( 1, 1 ), A( 1, 2 ), B( 1, 1 ), - $ B( 1, 3 ), WORK, IWORK, NOUT ) + CALL DCHKQ3( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, + $ NXVAL, THRESH, A( 1, 1 ), A( 1, 2 ), + $ B( 1, 1 ), B( 1, 3 ), WORK, IWORK, NOUT ) + ELSE + WRITE( NOUT, FMT = 9989 )PATH + END IF +* + ELSE IF( LSAMEN( 2, C2, 'QK' ) ) THEN +* +* QK: truncated QR factorization with pivoting +* + NTYPES = 19 + CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) +* + IF( TSTCHK ) THEN + CALL DCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, + $ NNB, NBVAL, NXVAL, THRESH, A( 1, 1 ), + $ A( 1, 2 ), B( 1, 1 ), B( 1, 2 ), + $ B( 1, 3 ), B( 1, 4 ), + $ WORK, IWORK, NOUT ) ELSE WRITE( NOUT, FMT = 9989 )PATH END IF diff --git a/lapack-netlib/TESTING/LIN/dchkq3.f b/lapack-netlib/TESTING/LIN/dchkq3.f index 1fdf07252..494008fa8 100644 --- a/lapack-netlib/TESTING/LIN/dchkq3.f +++ b/lapack-netlib/TESTING/LIN/dchkq3.f @@ -30,7 +30,7 @@ *> *> \verbatim *> -*> DCHKQ3 tests DGEQP3. +*> DCHKQ3 tests DGEQP3. *> \endverbatim * * Arguments: diff --git a/lapack-netlib/TESTING/LIN/dchkqp3rk.f b/lapack-netlib/TESTING/LIN/dchkqp3rk.f new file mode 100644 index 000000000..434d2067e --- /dev/null +++ b/lapack-netlib/TESTING/LIN/dchkqp3rk.f @@ -0,0 +1,832 @@ +*> \brief \b DCHKQP3RK +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, +* $ NNB, NBVAL, NXVAL, THRESH, A, COPYA, +* $ B, COPYB, S, TAU, +* $ WORK, IWORK, NOUT ) +* IMPLICIT NONE +* +* -- LAPACK test routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. +* INTEGER NM, NN, NNS, NNB, NOUT +* DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER IWORK( * ), MVAL( * ), NBVAL( * ), NSVAL( * ), +* $ NVAL( * ), NXVAL( * ) +* DOUBLE PRECISION A( * ), COPYA( * ), B( * ), COPYB( * ), +* $ S( * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DCHKQP3RK tests DGEQP3RK. +*> \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] NM +*> \verbatim +*> NM is INTEGER +*> The number of values of M contained in the vector MVAL. +*> \endverbatim +*> +*> \param[in] MVAL +*> \verbatim +*> MVAL is INTEGER array, dimension (NM) +*> The values of the matrix row dimension M. +*> \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 column dimension N. +*> \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] NNB +*> \verbatim +*> NNB is INTEGER +*> The number of values of NB and NX contained in the +*> vectors NBVAL and NXVAL. The blocking parameters are used +*> in pairs (NB,NX). +*> \endverbatim +*> +*> \param[in] NBVAL +*> \verbatim +*> NBVAL is INTEGER array, dimension (NNB) +*> The values of the blocksize NB. +*> \endverbatim +*> +*> \param[in] NXVAL +*> \verbatim +*> NXVAL is INTEGER array, dimension (NNB) +*> The values of the crossover point NX. +*> \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[out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (MMAX*NMAX) +*> where MMAX is the maximum value of M in MVAL and NMAX is the +*> maximum value of N in NVAL. +*> \endverbatim +*> +*> \param[out] COPYA +*> \verbatim +*> COPYA is DOUBLE PRECISION array, dimension (MMAX*NMAX) +*> \endverbatim +*> +*> \param[out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (MMAX*NSMAX) +*> where MMAX is the maximum value of M in MVAL and NSMAX is the +*> maximum value of NRHS in NSVAL. +*> \endverbatim +*> +*> \param[out] COPYB +*> \verbatim +*> COPYB is DOUBLE PRECISION array, dimension (MMAX*NSMAX) +*> \endverbatim +*> +*> \param[out] S +*> \verbatim +*> S is DOUBLE PRECISION array, dimension +*> (min(MMAX,NMAX)) +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION array, dimension (MMAX) +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension +*> (MMAX*NMAX + 4*NMAX + MMAX) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (2*NMAX) +*> \endverbatim +*> +*> \param[in] NOUT +*> \verbatim +*> NOUT is INTEGER +*> The unit number for output. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup double_lin +* +* ===================================================================== + SUBROUTINE DCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, + $ NNB, NBVAL, NXVAL, THRESH, A, COPYA, + $ B, COPYB, S, TAU, + $ WORK, IWORK, NOUT ) + IMPLICIT NONE +* +* -- LAPACK test routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER NM, NN, NNB, NNS, NOUT + DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER IWORK( * ), NBVAL( * ), MVAL( * ), NVAL( * ), + $ NSVAL( * ), NXVAL( * ) + DOUBLE PRECISION A( * ), COPYA( * ), B( * ), COPYB( * ), + $ S( * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER NTYPES + PARAMETER ( NTYPES = 19 ) + INTEGER NTESTS + PARAMETER ( NTESTS = 5 ) + DOUBLE PRECISION ONE, ZERO, BIGNUM + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0, + $ BIGNUM = 1.0D+38 ) +* .. +* .. Local Scalars .. + CHARACTER DIST, TYPE + CHARACTER*3 PATH + INTEGER I, IHIGH, ILOW, IM, IMAT, IN, INC_ZERO, + $ INB, IND_OFFSET_GEN, + $ IND_IN, IND_OUT, INS, INFO, + $ ISTEP, J, J_INC, J_FIRST_NZ, JB_ZERO, + $ KFACT, KL, KMAX, KU, LDA, LW, LWORK, + $ LWORK_MQR, M, MINMN, MINMNB_GEN, MODE, N, + $ NB, NB_ZERO, NERRS, NFAIL, NB_GEN, NRHS, + $ NRUN, NX, T + DOUBLE PRECISION ANORM, CNDNUM, EPS, ABSTOL, RELTOL, + $ DTEMP, MAXC2NRMK, RELMAXC2NRMK +* .. +* .. Local Arrays .. + INTEGER ISEED( 4 ), ISEEDY( 4 ) + DOUBLE PRECISION RESULT( NTESTS ), RDUMMY( 1 ) +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH, DQPT01, DQRT11, DQRT12, DLANGE, + $ DLAPY2 + EXTERNAL DLAMCH, DQPT01, DQRT11, DQRT12, DLANGE +* .. +* .. External Subroutines .. + EXTERNAL ALAERH, ALAHD, ALASUM, DAXPY, DGEQP3RK, + $ DLACPY, DLAORD, DLASET, DLATB4, DLATMS, + $ DORMQR, DSWAP, ICOPY, XLAENV +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, MAX, MIN, MOD +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, IOUNIT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, IOUNIT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Data statements .. + DATA ISEEDY / 1988, 1989, 1990, 1991 / +* .. +* .. Executable Statements .. +* +* Initialize constants and the random number seed. +* + PATH( 1: 1 ) = 'Double precision' + PATH( 2: 3 ) = 'QK' + NRUN = 0 + NFAIL = 0 + NERRS = 0 + DO I = 1, 4 + ISEED( I ) = ISEEDY( I ) + END DO + EPS = DLAMCH( 'Epsilon' ) + INFOT = 0 +* + DO IM = 1, NM +* +* Do for each value of M in MVAL. +* + M = MVAL( IM ) + LDA = MAX( 1, M ) +* + DO IN = 1, NN +* +* Do for each value of N in NVAL. +* + N = NVAL( IN ) + MINMN = MIN( M, N ) + LWORK = MAX( 1, M*MAX( M, N )+4*MINMN+MAX( M, N ), + $ M*N + 2*MINMN + 4*N ) +* + DO INS = 1, NNS + NRHS = NSVAL( INS ) +* +* Set up parameters with DLATB4 and generate +* M-by-NRHS B matrix with DLATMS. +* IMAT = 14: +* Random matrix, CNDNUM = 2, NORM = ONE, +* MODE = 3 (geometric distribution of singular values). +* + CALL DLATB4( PATH, 14, M, NRHS, TYPE, KL, KU, ANORM, + $ MODE, CNDNUM, DIST ) +* + SRNAMT = 'DLATMS' + CALL DLATMS( M, NRHS, DIST, ISEED, TYPE, S, MODE, + $ CNDNUM, ANORM, KL, KU, 'No packing', + $ COPYB, LDA, WORK, INFO ) + + +* +* Check error code from DLATMS. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'DLATMS', INFO, 0, ' ', M, + $ NRHS, -1, -1, -1, 6, NFAIL, NERRS, + $ NOUT ) + CYCLE + END IF +* + DO IMAT = 1, NTYPES +* +* Do the tests only if DOTYPE( IMAT ) is true. +* + IF( .NOT.DOTYPE( IMAT ) ) + $ CYCLE +* +* The type of distribution used to generate the random +* eigen-/singular values: +* ( 'S' for symmetric distribution ) => UNIFORM( -1, 1 ) +* +* Do for each type of NON-SYMMETRIC matrix: CNDNUM NORM MODE +* 1. Zero matrix +* 2. Random, Diagonal, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values ) +* 3. Random, Upper triangular, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values ) +* 4. Random, Lower triangular, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values ) +* 5. Random, First column is zero, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values ) +* 6. Random, Last MINMN column is zero, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values ) +* 7. Random, Last N column is zero, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values ) +* 8. Random, Middle column in MINMN is zero, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values ) +* 9. Random, First half of MINMN columns are zero, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values ) +* 10. Random, Last columns are zero starting from MINMN/2+1, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values ) +* 11. Random, Half MINMN columns in the middle are zero starting +* from MINMN/2-(MINMN/2)/2+1, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values ) +* 12. Random, Odd columns are ZERO, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values ) +* 13. Random, Even columns are ZERO, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values ) +* 14. Random, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values ) +* 15. Random, CNDNUM = sqrt(0.1/EPS) CNDNUM = BADC1 = sqrt(0.1/EPS) ONE 3 ( geometric distribution of singular values ) +* 16. Random, CNDNUM = 0.1/EPS CNDNUM = BADC2 = 0.1/EPS ONE 3 ( geometric distribution of singular values ) +* 17. Random, CNDNUM = 0.1/EPS, CNDNUM = BADC2 = 0.1/EPS ONE 2 ( one small singular value, S(N)=1/CNDNUM ) +* one small singular value S(N)=1/CNDNUM +* 18. Random, CNDNUM = 2, scaled near underflow CNDNUM = 2 SMALL = SAFMIN +* 19. Random, CNDNUM = 2, scaled near overflow CNDNUM = 2 LARGE = 1.0/( 0.25 * ( SAFMIN / EPS ) ) 3 ( geometric distribution of singular values ) +* + IF( IMAT.EQ.1 ) THEN +* +* Matrix 1: Zero matrix +* + CALL DLASET( 'Full', M, N, ZERO, ZERO, COPYA, LDA ) + DO I = 1, MINMN + S( I ) = ZERO + END DO +* + ELSE IF( (IMAT.GE.2 .AND. IMAT.LE.4 ) + $ .OR. (IMAT.GE.14 .AND. IMAT.LE.19 ) ) THEN +* +* Matrices 2-5. +* +* Set up parameters with DLATB4 and generate a test +* matrix with DLATMS. +* + CALL DLATB4( PATH, IMAT, M, N, TYPE, KL, KU, ANORM, + $ MODE, CNDNUM, DIST ) +* + SRNAMT = 'DLATMS' + CALL DLATMS( M, N, DIST, ISEED, TYPE, S, MODE, + $ CNDNUM, ANORM, KL, KU, 'No packing', + $ COPYA, LDA, WORK, INFO ) +* +* Check error code from DLATMS. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'DLATMS', INFO, 0, ' ', M, N, + $ -1, -1, -1, IMAT, NFAIL, NERRS, + $ NOUT ) + CYCLE + END IF +* + CALL DLAORD( 'Decreasing', MINMN, S, 1 ) +* + ELSE IF( MINMN.GE.2 + $ .AND. IMAT.GE.5 .AND. IMAT.LE.13 ) THEN +* +* Rectangular matrices 5-13 that contain zero columns, +* only for matrices MINMN >=2. +* +* JB_ZERO is the column index of ZERO block. +* NB_ZERO is the column block size of ZERO block. +* NB_GEN is the column blcok size of the +* generated block. +* J_INC in the non_zero column index increment +* for matrix 12 and 13. +* J_FIRS_NZ is the index of the first non-zero +* column. +* + IF( IMAT.EQ.5 ) THEN +* +* First column is zero. +* + JB_ZERO = 1 + NB_ZERO = 1 + NB_GEN = N - NB_ZERO +* + ELSE IF( IMAT.EQ.6 ) THEN +* +* Last column MINMN is zero. +* + JB_ZERO = MINMN + NB_ZERO = 1 + NB_GEN = N - NB_ZERO +* + ELSE IF( IMAT.EQ.7 ) THEN +* +* Last column N is zero. +* + JB_ZERO = N + NB_ZERO = 1 + NB_GEN = N - NB_ZERO +* + ELSE IF( IMAT.EQ.8 ) THEN +* +* Middle column in MINMN is zero. +* + JB_ZERO = MINMN / 2 + 1 + NB_ZERO = 1 + NB_GEN = N - NB_ZERO +* + ELSE IF( IMAT.EQ.9 ) THEN +* +* First half of MINMN columns is zero. +* + JB_ZERO = 1 + NB_ZERO = MINMN / 2 + NB_GEN = N - NB_ZERO +* + ELSE IF( IMAT.EQ.10 ) THEN +* +* Last columns are zero columns, +* starting from (MINMN / 2 + 1) column. +* + JB_ZERO = MINMN / 2 + 1 + NB_ZERO = N - JB_ZERO + 1 + NB_GEN = N - NB_ZERO +* + ELSE IF( IMAT.EQ.11 ) THEN +* +* Half of the columns in the middle of MINMN +* columns is zero, starting from +* MINMN/2 - (MINMN/2)/2 + 1 column. +* + JB_ZERO = MINMN / 2 - (MINMN / 2) / 2 + 1 + NB_ZERO = MINMN / 2 + NB_GEN = N - NB_ZERO +* + ELSE IF( IMAT.EQ.12 ) THEN +* +* Odd-numbered columns are zero, +* + NB_GEN = N / 2 + NB_ZERO = N - NB_GEN + J_INC = 2 + J_FIRST_NZ = 2 +* + ELSE IF( IMAT.EQ.13 ) THEN +* +* Even-numbered columns are zero. +* + NB_ZERO = N / 2 + NB_GEN = N - NB_ZERO + J_INC = 2 + J_FIRST_NZ = 1 +* + END IF +* +* +* 1) Set the first NB_ZERO columns in COPYA(1:M,1:N) +* to zero. +* + CALL DLASET( 'Full', M, NB_ZERO, ZERO, ZERO, + $ COPYA, LDA ) +* +* 2) Generate an M-by-(N-NB_ZERO) matrix with the +* chosen singular value distribution +* in COPYA(1:M,NB_ZERO+1:N). +* + CALL DLATB4( PATH, IMAT, M, NB_GEN, TYPE, KL, KU, + $ ANORM, MODE, CNDNUM, DIST ) +* + SRNAMT = 'DLATMS' +* + IND_OFFSET_GEN = NB_ZERO * LDA +* + CALL DLATMS( M, NB_GEN, DIST, ISEED, TYPE, S, MODE, + $ CNDNUM, ANORM, KL, KU, 'No packing', + $ COPYA( IND_OFFSET_GEN + 1 ), LDA, + $ WORK, INFO ) +* +* Check error code from DLATMS. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'DLATMS', INFO, 0, ' ', M, + $ NB_GEN, -1, -1, -1, IMAT, NFAIL, + $ NERRS, NOUT ) + CYCLE + END IF +* +* 3) Swap the gererated colums from the right side +* NB_GEN-size block in COPYA into correct column +* positions. +* + IF( IMAT.EQ.6 + $ .OR. IMAT.EQ.7 + $ .OR. IMAT.EQ.8 + $ .OR. IMAT.EQ.10 + $ .OR. IMAT.EQ.11 ) THEN +* +* Move by swapping the generated columns +* from the right NB_GEN-size block from +* (NB_ZERO+1:NB_ZERO+JB_ZERO) +* into columns (1:JB_ZERO-1). +* + DO J = 1, JB_ZERO-1, 1 + CALL DSWAP( M, + $ COPYA( ( NB_ZERO+J-1)*LDA+1), 1, + $ COPYA( (J-1)*LDA + 1 ), 1 ) + END DO +* + ELSE IF( IMAT.EQ.12 .OR. IMAT.EQ.13 ) THEN +* +* ( IMAT = 12, Odd-numbered ZERO columns. ) +* Swap the generated columns from the right +* NB_GEN-size block into the even zero colums in the +* left NB_ZERO-size block. +* +* ( IMAT = 13, Even-numbered ZERO columns. ) +* Swap the generated columns from the right +* NB_GEN-size block into the odd zero colums in the +* left NB_ZERO-size block. +* + DO J = 1, NB_GEN, 1 + IND_OUT = ( NB_ZERO+J-1 )*LDA + 1 + IND_IN = ( J_INC*(J-1)+(J_FIRST_NZ-1) )*LDA + $ + 1 + CALL DSWAP( M, + $ COPYA( IND_OUT ), 1, + $ COPYA( IND_IN), 1 ) + END DO +* + END IF +* +* 5) Order the singular values generated by +* DLAMTS in decreasing order and add trailing zeros +* that correspond to zero columns. +* The total number of singular values is MINMN. +* + MINMNB_GEN = MIN( M, NB_GEN ) +* + DO I = MINMNB_GEN+1, MINMN + S( I ) = ZERO + END DO +* + ELSE +* +* IF(MINMN.LT.2) skip this size for this matrix type. +* + CYCLE + END IF +* +* Initialize a copy array for a pivot array for DGEQP3RK. +* + DO I = 1, N + IWORK( I ) = 0 + END DO +* + DO INB = 1, NNB +* +* Do for each pair of values (NB,NX) in NBVAL and NXVAL. +* + NB = NBVAL( INB ) + CALL XLAENV( 1, NB ) + NX = NXVAL( INB ) + CALL XLAENV( 3, NX ) +* +* We do MIN(M,N)+1 because we need a test for KMAX > N, +* when KMAX is larger than MIN(M,N), KMAX should be +* KMAX = MIN(M,N) +* + DO KMAX = 0, MIN(M,N)+1 +* +* Get a working copy of COPYA into A( 1:M,1:N ). +* Get a working copy of COPYB into A( 1:M, (N+1):NRHS ). +* Get a working copy of COPYB into into B( 1:M, 1:NRHS ). +* Get a working copy of IWORK(1:N) awith zeroes into +* which is going to be used as pivot array IWORK( N+1:2N ). +* NOTE: IWORK(2N+1:3N) is going to be used as a WORK array +* for the routine. +* + CALL DLACPY( 'All', M, N, COPYA, LDA, A, LDA ) + CALL DLACPY( 'All', M, NRHS, COPYB, LDA, + $ A( LDA*N + 1 ), LDA ) + CALL DLACPY( 'All', M, NRHS, COPYB, LDA, + $ B, LDA ) + CALL ICOPY( N, IWORK( 1 ), 1, IWORK( N+1 ), 1 ) +* + ABSTOL = -1.0 + RELTOL = -1.0 +* +* Compute the QR factorization with pivoting of A +* + LW = MAX( 1, MAX( 2*N + NB*( N+NRHS+1 ), + $ 3*N + NRHS - 1 ) ) +* +* Compute DGEQP3RK factorization of A. +* + SRNAMT = 'DGEQP3RK' + CALL DGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, + $ A, LDA, KFACT, MAXC2NRMK, + $ RELMAXC2NRMK, IWORK( N+1 ), TAU, + $ WORK, LW, IWORK( 2*N+1 ), INFO ) +* +* Check error code from DGEQP3RK. +* + IF( INFO.LT.0 ) + $ CALL ALAERH( PATH, 'DGEQP3RK', INFO, 0, ' ', + $ M, N, NX, -1, NB, IMAT, + $ NFAIL, NERRS, NOUT ) +* +* Compute test 1: +* +* This test in only for the full rank factorization of +* the matrix A. +* +* Array S(1:min(M,N)) contains svd(A) the sigular values +* of the original matrix A in decreasing absolute value +* order. The test computes svd(R), the vector sigular +* values of the upper trapezoid of A(1:M,1:N) that +* contains the factor R, in decreasing order. The test +* returns the ratio: +* +* 2-norm(svd(R) - svd(A)) / ( max(M,N) * 2-norm(svd(A)) * EPS ) +* + IF( KFACT.EQ.MINMN ) THEN +* + RESULT( 1 ) = DQRT12( M, N, A, LDA, S, WORK, + $ LWORK ) +* + DO T = 1, 1 + IF( RESULT( T ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 ) 'DGEQP3RK', M, N, + $ NRHS, KMAX, ABSTOL, RELTOL, NB, NX, + $ IMAT, T, RESULT( T ) + NFAIL = NFAIL + 1 + END IF + END DO + NRUN = NRUN + 1 +* +* End test 1 +* + END IF +* +* Compute test 2: +* +* The test returns the ratio: +* +* 1-norm( A*P - Q*R ) / ( max(M,N) * 1-norm(A) * EPS ) +* + RESULT( 2 ) = DQPT01( M, N, KFACT, COPYA, A, LDA, TAU, + $ IWORK( N+1 ), WORK, LWORK ) +* +* Compute test 3: +* +* The test returns the ratio: +* +* 1-norm( Q**T * Q - I ) / ( M * EPS ) +* + RESULT( 3 ) = DQRT11( M, KFACT, A, LDA, TAU, WORK, + $ LWORK ) +* +* Print information about the tests that did not pass +* the threshold. +* + DO T = 2, 3 + IF( RESULT( T ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 ) 'DGEQP3RK', M, N, + $ NRHS, KMAX, ABSTOL, RELTOL, + $ NB, NX, IMAT, T, RESULT( T ) + NFAIL = NFAIL + 1 + END IF + END DO + NRUN = NRUN + 2 +* +* Compute test 4: +* +* This test is only for the factorizations with the +* rank greater than 2. +* The elements on the diagonal of R should be non- +* increasing. +* +* The test returns the ratio: +* +* Returns 1.0D+100 if abs(R(K+1,K+1)) > abs(R(K,K)), +* K=1:KFACT-1 +* + IF( MIN(KFACT, MINMN).GE.2 ) THEN +* + DO J = 1, KFACT-1, 1 + + DTEMP = (( ABS( A( (J-1)*M+J ) ) - + $ ABS( A( (J)*M+J+1 ) ) ) / + $ ABS( A(1) ) ) +* + IF( DTEMP.LT.ZERO ) THEN + RESULT( 4 ) = BIGNUM + END IF +* + END DO +* +* Print information about the tests that did not +* pass the threshold. +* + DO T = 4, 4 + IF( RESULT( T ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 ) 'DGEQP3RK', + $ M, N, NRHS, KMAX, ABSTOL, RELTOL, + $ NB, NX, IMAT, T, + $ RESULT( T ) + NFAIL = NFAIL + 1 + END IF + END DO + NRUN = NRUN + 1 +* +* End test 4. +* + END IF +* +* Compute test 5: +* +* This test in only for matrix A with min(M,N) > 0. +* +* The test returns the ratio: +* +* 1-norm(Q**T * B - Q**T * B ) / +* ( M * EPS ) +* +* (1) Compute B:=Q**T * B in the matrix B. +* + IF( MINMN.GT.0 ) THEN +* + LWORK_MQR = MAX(1, NRHS) + CALL DORMQR( 'Left', 'Transpose', + $ M, NRHS, KFACT, A, LDA, TAU, B, LDA, + $ WORK, LWORK_MQR, INFO ) +* + DO I = 1, NRHS +* +* Compare N+J-th column of A and J-column of B. +* + CALL DAXPY( M, -ONE, A( ( N+I-1 )*LDA+1 ), 1, + $ B( ( I-1 )*LDA+1 ), 1 ) + END DO +* + RESULT( 5 ) = + $ ABS( + $ DLANGE( 'One-norm', M, NRHS, B, LDA, RDUMMY ) / + $ ( DBLE( M )*DLAMCH( 'Epsilon' ) ) + $ ) +* +* Print information about the tests that did not pass +* the threshold. +* + DO T = 5, 5 + IF( RESULT( T ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 ) 'DGEQP3RK', M, N, + $ NRHS, KMAX, ABSTOL, RELTOL, + $ NB, NX, IMAT, T, RESULT( T ) + NFAIL = NFAIL + 1 + END IF + END DO + NRUN = NRUN + 1 +* +* End compute test 5. +* + END IF +* +* END DO KMAX = 1, MIN(M,N)+1 +* + END DO +* +* END DO for INB = 1, NNB +* + END DO +* +* END DO for IMAT = 1, NTYPES +* + END DO +* +* END DO for INS = 1, NNS +* + END DO +* +* END DO for IN = 1, NN +* + END DO +* +* END DO for IM = 1, NM +* + END DO +* +* Print a summary of the results. +* + CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) +* + 9999 FORMAT( 1X, A, ' M =', I5, ', N =', I5, ', NRHS =', I5, + $ ', KMAX =', I5, ', ABSTOL =', G12.5, + $ ', RELTOL =', G12.5, ', NB =', I4, ', NX =', I4, + $ ', type ', I2, ', test ', I2, ', ratio =', G12.5 ) +* +* End of DCHKQP3RK +* + END diff --git a/lapack-netlib/TESTING/LIN/dlatb4.f b/lapack-netlib/TESTING/LIN/dlatb4.f index 8825d13e7..f3bccd45b 100644 --- a/lapack-netlib/TESTING/LIN/dlatb4.f +++ b/lapack-netlib/TESTING/LIN/dlatb4.f @@ -133,7 +133,7 @@ * * .. Parameters .. DOUBLE PRECISION SHRINK, TENTH - PARAMETER ( SHRINK = 0.25D0, TENTH = 0.1D+0 ) + PARAMETER ( SHRINK = 0.25D+0, TENTH = 0.1D+0 ) DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) DOUBLE PRECISION TWO @@ -153,9 +153,6 @@ * .. Intrinsic Functions .. INTRINSIC ABS, MAX, SQRT * .. -* .. External Subroutines .. - EXTERNAL DLABAD -* .. * .. Save statement .. SAVE EPS, SMALL, LARGE, BADC1, BADC2, FIRST * .. @@ -173,11 +170,6 @@ BADC1 = SQRT( BADC2 ) SMALL = DLAMCH( 'Safe minimum' ) LARGE = ONE / SMALL -* -* If it looks like we're on a Cray, take the square root of -* SMALL and LARGE to avoid overflow and underflow problems. -* - CALL DLABAD( SMALL, LARGE ) SMALL = SHRINK*( SMALL / EPS ) LARGE = ONE / SMALL END IF @@ -232,6 +224,110 @@ ELSE ANORM = ONE END IF +* + ELSE IF( LSAMEN( 2, C2, 'QK' ) ) THEN +* +* xQK: truncated QR with pivoting. +* Set parameters to generate a general +* M x N matrix. +* +* Set TYPE, the type of matrix to be generated. 'N' is nonsymmetric. +* + TYPE = 'N' +* +* Set DIST, the type of distribution for the random +* number generator. 'S' is +* + DIST = 'S' +* +* Set the lower and upper bandwidths. +* + IF( IMAT.EQ.2 ) THEN +* +* 2. Random, Diagonal, CNDNUM = 2 +* + KL = 0 + KU = 0 + CNDNUM = TWO + ANORM = ONE + MODE = 3 + ELSE IF( IMAT.EQ.3 ) THEN +* +* 3. Random, Upper triangular, CNDNUM = 2 +* + KL = 0 + KU = MAX( N-1, 0 ) + CNDNUM = TWO + ANORM = ONE + MODE = 3 + ELSE IF( IMAT.EQ.4 ) THEN +* +* 4. Random, Lower triangular, CNDNUM = 2 +* + KL = MAX( M-1, 0 ) + KU = 0 + CNDNUM = TWO + ANORM = ONE + MODE = 3 + ELSE +* +* 5.-19. Rectangular matrix +* + KL = MAX( M-1, 0 ) + KU = MAX( N-1, 0 ) +* + IF( IMAT.GE.5 .AND. IMAT.LE.14 ) THEN +* +* 5.-14. Random, CNDNUM = 2. +* + CNDNUM = TWO + ANORM = ONE + MODE = 3 +* + ELSE IF( IMAT.EQ.15 ) THEN +* +* 15. Random, CNDNUM = sqrt(0.1/EPS) +* + CNDNUM = BADC1 + ANORM = ONE + MODE = 3 +* + ELSE IF( IMAT.EQ.16 ) THEN +* +* 16. Random, CNDNUM = 0.1/EPS +* + CNDNUM = BADC2 + ANORM = ONE + MODE = 3 +* + ELSE IF( IMAT.EQ.17 ) THEN +* +* 17. Random, CNDNUM = 0.1/EPS, +* one small singular value S(N)=1/CNDNUM +* + CNDNUM = BADC2 + ANORM = ONE + MODE = 2 +* + ELSE IF( IMAT.EQ.18 ) THEN +* +* 18. Random, scaled near underflow +* + CNDNUM = TWO + ANORM = SMALL + MODE = 3 +* + ELSE IF( IMAT.EQ.19 ) THEN +* +* 19. Random, scaled near overflow +* + CNDNUM = TWO + ANORM = LARGE + MODE = 3 +* + END IF +* + END IF * ELSE IF( LSAMEN( 2, C2, 'GE' ) ) THEN * @@ -518,17 +614,18 @@ * * Set the norm and condition number. * - IF( IMAT.EQ.2 .OR. IMAT.EQ.8 ) THEN + MAT = ABS( IMAT ) + IF( MAT.EQ.2 .OR. MAT.EQ.8 ) THEN CNDNUM = BADC1 - ELSE IF( IMAT.EQ.3 .OR. IMAT.EQ.9 ) THEN + ELSE IF( MAT.EQ.3 .OR. MAT.EQ.9 ) THEN CNDNUM = BADC2 ELSE CNDNUM = TWO END IF * - IF( IMAT.EQ.4 ) THEN + IF( MAT.EQ.4 ) THEN ANORM = SMALL - ELSE IF( IMAT.EQ.5 ) THEN + ELSE IF( MAT.EQ.5 ) THEN ANORM = LARGE ELSE ANORM = ONE diff --git a/lapack-netlib/TESTING/LIN/dqpt01.f b/lapack-netlib/TESTING/LIN/dqpt01.f index 8efbdc774..af3f5dd36 100644 --- a/lapack-netlib/TESTING/LIN/dqpt01.f +++ b/lapack-netlib/TESTING/LIN/dqpt01.f @@ -28,12 +28,13 @@ *> *> DQPT01 tests the QR-factorization with pivoting of a matrix A. The *> array AF contains the (possibly partial) QR-factorization of A, where -*> the upper triangle of AF(1:k,1:k) is a partial triangular factor, -*> the entries below the diagonal in the first k columns are the +*> the upper triangle of AF(1:K,1:K) is a partial triangular factor, +*> the entries below the diagonal in the first K columns are the *> Householder vectors, and the rest of AF contains a partially updated *> matrix. *> -*> This function returns ||A*P - Q*R||/(||norm(A)||*eps*M) +*> This function returns ||A*P - Q*R|| / ( ||norm(A)||*eps*max(M,N) ), +*> where || . || is matrix one norm. *> \endverbatim * * Arguments: @@ -172,28 +173,41 @@ * NORMA = DLANGE( 'One-norm', M, N, A, LDA, RWORK ) * - DO 30 J = 1, K - DO 10 I = 1, MIN( J, M ) + DO J = 1, K +* +* Copy the upper triangular part of the factor R stored +* in AF(1:K,1:K) into the work array WORK. +* + DO I = 1, MIN( J, M ) WORK( ( J-1 )*M+I ) = AF( I, J ) - 10 CONTINUE - DO 20 I = J + 1, M + END DO +* +* Zero out the elements below the diagonal in the work array. +* + DO I = J + 1, M WORK( ( J-1 )*M+I ) = ZERO - 20 CONTINUE - 30 CONTINUE - DO 40 J = K + 1, N + END DO + END DO +* +* Copy columns (K+1,N) from AF into the work array WORK. +* AF(1:K,K+1:N) contains the rectangular block of the upper trapezoidal +* factor R, AF(K+1:M,K+1:N) contains the partially updated residual +* matrix of R. +* + DO J = K + 1, N CALL DCOPY( M, AF( 1, J ), 1, WORK( ( J-1 )*M+1 ), 1 ) - 40 CONTINUE + END DO * CALL DORMQR( 'Left', 'No transpose', M, N, K, AF, LDA, TAU, WORK, $ M, WORK( M*N+1 ), LWORK-M*N, INFO ) * - DO 50 J = 1, N + DO J = 1, N * -* Compare i-th column of QR and jpvt(i)-th column of A +* Compare J-th column of QR and JPVT(J)-th column of A. * CALL DAXPY( M, -ONE, A( 1, JPVT( J ) ), 1, WORK( ( J-1 )*M+1 ), $ 1 ) - 50 CONTINUE + END DO * DQPT01 = DLANGE( 'One-norm', M, N, WORK, M, RWORK ) / $ ( DBLE( MAX( M, N ) )*DLAMCH( 'Epsilon' ) ) diff --git a/lapack-netlib/TESTING/LIN/dqrt11.f b/lapack-netlib/TESTING/LIN/dqrt11.f index 33c7fab37..38bbeb822 100644 --- a/lapack-netlib/TESTING/LIN/dqrt11.f +++ b/lapack-netlib/TESTING/LIN/dqrt11.f @@ -157,9 +157,9 @@ CALL DORM2R( 'Left', 'Transpose', M, M, K, A, LDA, TAU, WORK, M, $ WORK( M*M+1 ), INFO ) * - DO 10 J = 1, M + DO J = 1, M WORK( ( J-1 )*M+J ) = WORK( ( J-1 )*M+J ) - ONE - 10 CONTINUE + END DO * DQRT11 = DLANGE( 'One-norm', M, M, WORK, M, RDUMMY ) / $ ( DBLE( M )*DLAMCH( 'Epsilon' ) ) diff --git a/lapack-netlib/TESTING/LIN/dqrt12.f b/lapack-netlib/TESTING/LIN/dqrt12.f index 278e01bf0..b8a124c59 100644 --- a/lapack-netlib/TESTING/LIN/dqrt12.f +++ b/lapack-netlib/TESTING/LIN/dqrt12.f @@ -26,7 +26,7 @@ *> DQRT12 computes the singular values `svlues' of the upper trapezoid *> of A(1:M,1:N) and returns the ratio *> -*> || s - svlues||/(||svlues||*eps*max(M,N)) +*> || svlues - s ||/(||s||*eps*max(M,N)) *> \endverbatim * * Arguments: @@ -113,8 +113,7 @@ EXTERNAL DASUM, DLAMCH, DLANGE, DNRM2 * .. * .. External Subroutines .. - EXTERNAL DAXPY, DBDSQR, DGEBD2, DLABAD, DLASCL, DLASET, - $ XERBLA + EXTERNAL DAXPY, DBDSQR, DGEBD2, DLASCL, DLASET, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC DBLE, MAX, MIN @@ -145,17 +144,16 @@ * Copy upper triangle of A into work * CALL DLASET( 'Full', M, N, ZERO, ZERO, WORK, M ) - DO 20 J = 1, N - DO 10 I = 1, MIN( J, M ) + DO J = 1, N + DO I = 1, MIN( J, M ) WORK( ( J-1 )*M+I ) = A( I, J ) - 10 CONTINUE - 20 CONTINUE + END DO + END DO * * Get machine parameters * SMLNUM = DLAMCH( 'S' ) / DLAMCH( 'P' ) BIGNUM = ONE / SMLNUM - CALL DLABAD( SMLNUM, BIGNUM ) * * Scale work if max entry outside range [SMLNUM,BIGNUM] * @@ -199,16 +197,18 @@ * ELSE * - DO 30 I = 1, MN + DO I = 1, MN WORK( M*N+I ) = ZERO - 30 CONTINUE + END DO END IF * * Compare s and singular values of work * CALL DAXPY( MN, -ONE, S, 1, WORK( M*N+1 ), 1 ) +* DQRT12 = DASUM( MN, WORK( M*N+1 ), 1 ) / - $ ( DLAMCH( 'Epsilon' )*DBLE( MAX( M, N ) ) ) + $ ( DLAMCH('Epsilon') * DBLE( MAX( M, N ) ) ) +* IF( NRMSVL.NE.ZERO ) $ DQRT12 = DQRT12 / NRMSVL * diff --git a/lapack-netlib/TESTING/LIN/schkaa.F b/lapack-netlib/TESTING/LIN/schkaa.F index a5b826d06..2b9f2ea45 100644 --- a/lapack-netlib/TESTING/LIN/schkaa.F +++ b/lapack-netlib/TESTING/LIN/schkaa.F @@ -63,6 +63,7 @@ *> SLQ 8 List types on next line if 0 < NTYPES < 8 *> SQL 8 List types on next line if 0 < NTYPES < 8 *> SQP 6 List types on next line if 0 < NTYPES < 6 +*> DQK 19 List types on next line if 0 < NTYPES < 19 *> STZ 3 List types on next line if 0 < NTYPES < 3 *> SLS 6 List types on next line if 0 < NTYPES < 6 *> SEQ @@ -147,11 +148,11 @@ $ NBVAL( MAXIN ), NBVAL2( MAXIN ), $ NSVAL( MAXIN ), NVAL( MAXIN ), NXVAL( MAXIN ), $ RANKVAL( MAXIN ), PIV( NMAX ) - REAL E( NMAX ), S( 2*NMAX ) * .. * .. Allocatable Arrays .. INTEGER AllocateStatus - REAL, DIMENSION(:), ALLOCATABLE :: RWORK + REAL, DIMENSION(:), ALLOCATABLE :: RWORK, S + REAL, DIMENSION(:), ALLOCATABLE :: E REAL, DIMENSION(:,:), ALLOCATABLE :: A, B, WORK * .. * .. External Functions .. @@ -162,13 +163,13 @@ * .. External Subroutines .. EXTERNAL ALAREQ, SCHKEQ, SCHKGB, SCHKGE, SCHKGT, SCHKLQ, $ SCHKORHR_COL, SCHKPB, SCHKPO, SCHKPS, SCHKPP, - $ SCHKPT, SCHKQ3, SCHKQL, SCHKQR, SCHKRQ, SCHKSP, - $ SCHKSY, SCHKSY_ROOK, SCHKSY_RK, SCHKSY_AA, - $ SCHKTB, SCHKTP, SCHKTR, SCHKTZ, SDRVGB, SDRVGE, - $ SDRVGT, SDRVLS, SDRVPB, SDRVPO, SDRVPP, SDRVPT, - $ SDRVSP, SDRVSY, SDRVSY_ROOK, SDRVSY_RK, - $ SDRVSY_AA, ILAVER, SCHKLQTP, SCHKQRT, SCHKQRTP, - $ SCHKLQT, SCHKTSQR + $ SCHKPT, SCHKQ3, SCHKQP3RK, SCHKQL, SCHKQR, + $ SCHKRQ, SCHKSP, SCHKSY, SCHKSY_ROOK, SCHKSY_RK, + $ SCHKSY_AA, SCHKTB, SCHKTP, SCHKTR, SCHKTZ, + $ SDRVGB, SDRVGE, SDRVGT, SDRVLS, SDRVPB, SDRVPO, + $ SDRVPP, SDRVPT, SDRVSP, SDRVSY, SDRVSY_ROOK, + $ SDRVSY_RK, SDRVSY_AA, ILAVER, SCHKLQTP, SCHKQRT, + $ SCHKQRTP, SCHKLQT, SCHKTSQR * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -188,13 +189,17 @@ * .. * .. Allocate memory dynamically .. * - ALLOCATE (A( ( KDMAX+1 )*NMAX, 7 ), STAT = AllocateStatus ) + ALLOCATE ( A( ( KDMAX+1 )*NMAX, 7 ), STAT = AllocateStatus ) IF (AllocateStatus /= 0) STOP "*** Not enough memory ***" - ALLOCATE (B( NMAX*MAXRHS, 4 ), STAT = AllocateStatus ) + ALLOCATE ( B( NMAX*MAXRHS, 4 ), STAT = AllocateStatus ) IF (AllocateStatus /= 0) STOP "*** Not enough memory ***" - ALLOCATE (WORK( NMAX, NMAX+MAXRHS+30 ) , STAT = AllocateStatus ) + ALLOCATE ( WORK( NMAX, 3*NMAX+MAXRHS+30 ), STAT = AllocateStatus ) IF (AllocateStatus /= 0) STOP "*** Not enough memory ***" - ALLOCATE (RWORK( 5*NMAX+2*MAXRHS ), STAT = AllocateStatus ) + ALLOCATE ( E( NMAX ), STAT = AllocateStatus ) + IF (AllocateStatus /= 0) STOP "*** Not enough memory ***" + ALLOCATE ( S( 2*NMAX ), STAT = AllocateStatus ) + IF (AllocateStatus /= 0) STOP "*** Not enough memory ***" + ALLOCATE ( RWORK( 5*NMAX+2*MAXRHS ), STAT = AllocateStatus ) IF (AllocateStatus /= 0) STOP "*** Not enough memory ***" * .. * .. Executable Statements .. @@ -920,6 +925,23 @@ ELSE WRITE( NOUT, FMT = 9989 )PATH END IF +* + ELSE IF( LSAMEN( 2, C2, 'QK' ) ) THEN +* +* QK: truncated QR factorization with pivoting +* + NTYPES = 19 + CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) +* + IF( TSTCHK ) THEN + CALL SCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, + $ NNB, NBVAL, NXVAL, THRESH, A( 1, 1 ), + $ A( 1, 2 ), B( 1, 1 ), B( 1, 2 ), + $ B( 1, 3 ), B( 1, 4 ), + $ WORK, IWORK, NOUT ) + ELSE + WRITE( NOUT, FMT = 9989 )PATH + END IF * ELSE IF( LSAMEN( 2, C2, 'TZ' ) ) THEN * diff --git a/lapack-netlib/TESTING/LIN/schkqp3rk.f b/lapack-netlib/TESTING/LIN/schkqp3rk.f new file mode 100644 index 000000000..36cf9370e --- /dev/null +++ b/lapack-netlib/TESTING/LIN/schkqp3rk.f @@ -0,0 +1,831 @@ +*> \brief \b SCHKQP3RK +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, +* $ NNB, NBVAL, NXVAL, THRESH, A, COPYA, +* $ B, COPYB, S, TAU, +* $ WORK, IWORK, NOUT ) +* IMPLICIT NONE +* +* -- LAPACK test routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. +* INTEGER NM, NN, NNS, NNB, NOUT +* REAL THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER IWORK( * ), MVAL( * ), NBVAL( * ), NSVAL( * ), +* $ NVAL( * ), NXVAL( * ) +* REAL A( * ), COPYA( * ), B( * ), COPYB( * ), +* $ S( * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SCHKQP3RK tests SGEQP3RK. +*> \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] NM +*> \verbatim +*> NM is INTEGER +*> The number of values of M contained in the vector MVAL. +*> \endverbatim +*> +*> \param[in] MVAL +*> \verbatim +*> MVAL is INTEGER array, dimension (NM) +*> The values of the matrix row dimension M. +*> \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 column dimension N. +*> \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] NNB +*> \verbatim +*> NNB is INTEGER +*> The number of values of NB and NX contained in the +*> vectors NBVAL and NXVAL. The blocking parameters are used +*> in pairs (NB,NX). +*> \endverbatim +*> +*> \param[in] NBVAL +*> \verbatim +*> NBVAL is INTEGER array, dimension (NNB) +*> The values of the blocksize NB. +*> \endverbatim +*> +*> \param[in] NXVAL +*> \verbatim +*> NXVAL is INTEGER array, dimension (NNB) +*> The values of the crossover point NX. +*> \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[out] A +*> \verbatim +*> A is REAL array, dimension (MMAX*NMAX) +*> where MMAX is the maximum value of M in MVAL and NMAX is the +*> maximum value of N in NVAL. +*> \endverbatim +*> +*> \param[out] COPYA +*> \verbatim +*> COPYA is REAL array, dimension (MMAX*NMAX) +*> \endverbatim +*> +*> \param[out] B +*> \verbatim +*> B is REAL array, dimension (MMAX*NSMAX) +*> where MMAX is the maximum value of M in MVAL and NSMAX is the +*> maximum value of NRHS in NSVAL. +*> \endverbatim +*> +*> \param[out] COPYB +*> \verbatim +*> COPYB is REAL array, dimension (MMAX*NSMAX) +*> \endverbatim +*> +*> \param[out] S +*> \verbatim +*> S is REAL array, dimension +*> (min(MMAX,NMAX)) +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is REAL array, dimension (MMAX) +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is REAL array, dimension +*> (MMAX*NMAX + 4*NMAX + MMAX) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (2*NMAX) +*> \endverbatim +*> +*> \param[in] NOUT +*> \verbatim +*> NOUT is INTEGER +*> The unit number for output. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup single_lin +* +* ===================================================================== + SUBROUTINE SCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, + $ NNB, NBVAL, NXVAL, THRESH, A, COPYA, + $ B, COPYB, S, TAU, + $ WORK, IWORK, NOUT ) + IMPLICIT NONE +* +* -- LAPACK test routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER NM, NN, NNB, NNS, NOUT + REAL THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER IWORK( * ), NBVAL( * ), MVAL( * ), NVAL( * ), + $ NSVAL( * ), NXVAL( * ) + REAL A( * ), COPYA( * ), B( * ), COPYB( * ), + $ S( * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER NTYPES + PARAMETER ( NTYPES = 19 ) + INTEGER NTESTS + PARAMETER ( NTESTS = 5 ) + REAL ONE, ZERO, BIGNUM + PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0, + $ BIGNUM = 1.0E+38 ) +* .. +* .. Local Scalars .. + CHARACTER DIST, TYPE + CHARACTER*3 PATH + INTEGER I, IHIGH, ILOW, IM, IMAT, IN, INC_ZERO, + $ INB, IND_OFFSET_GEN, + $ IND_IN, IND_OUT, INS, INFO, + $ ISTEP, J, J_INC, J_FIRST_NZ, JB_ZERO, + $ KFACT, KL, KMAX, KU, LDA, LW, LWORK, + $ LWORK_MQR, M, MINMN, MINMNB_GEN, MODE, N, + $ NB, NB_ZERO, NERRS, NFAIL, NB_GEN, NRHS, + $ NRUN, NX, T + REAL ANORM, CNDNUM, EPS, ABSTOL, RELTOL, + $ DTEMP, MAXC2NRMK, RELMAXC2NRMK +* .. +* .. Local Arrays .. + INTEGER ISEED( 4 ), ISEEDY( 4 ) + REAL RESULT( NTESTS ), RDUMMY( 1 ) +* .. +* .. External Functions .. + REAL SLAMCH, SQPT01, SQRT11, SQRT12, SLANGE + EXTERNAL SLAMCH, SQPT01, SQRT11, SQRT12, SLANGE +* .. +* .. External Subroutines .. + EXTERNAL ALAERH, ALAHD, ALASUM, SAXPY, SGEQP3RK, + $ SLACPY, SLAORD, SLASET, SLATB4, SLATMS, + $ SORMQR, SSWAP, ICOPY, XLAENV +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, MOD, REAL +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, IOUNIT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, IOUNIT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Data statements .. + DATA ISEEDY / 1988, 1989, 1990, 1991 / +* .. +* .. Executable Statements .. +* +* Initialize constants and the random number seed. +* + PATH( 1: 1 ) = 'Single precision' + PATH( 2: 3 ) = 'QK' + NRUN = 0 + NFAIL = 0 + NERRS = 0 + DO I = 1, 4 + ISEED( I ) = ISEEDY( I ) + END DO + EPS = SLAMCH( 'Epsilon' ) + INFOT = 0 +* + DO IM = 1, NM +* +* Do for each value of M in MVAL. +* + M = MVAL( IM ) + LDA = MAX( 1, M ) +* + DO IN = 1, NN +* +* Do for each value of N in NVAL. +* + N = NVAL( IN ) + MINMN = MIN( M, N ) + LWORK = MAX( 1, M*MAX( M, N )+4*MINMN+MAX( M, N ), + $ M*N + 2*MINMN + 4*N ) +* + DO INS = 1, NNS + NRHS = NSVAL( INS ) +* +* Set up parameters with SLATB4 and generate +* M-by-NRHS B matrix with SLATMS. +* IMAT = 14: +* Random matrix, CNDNUM = 2, NORM = ONE, +* MODE = 3 (geometric distribution of singular values). +* + CALL SLATB4( PATH, 14, M, NRHS, TYPE, KL, KU, ANORM, + $ MODE, CNDNUM, DIST ) +* + SRNAMT = 'SLATMS' + CALL SLATMS( M, NRHS, DIST, ISEED, TYPE, S, MODE, + $ CNDNUM, ANORM, KL, KU, 'No packing', + $ COPYB, LDA, WORK, INFO ) + + +* +* Check error code from SLATMS. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'SLATMS', INFO, 0, ' ', M, + $ NRHS, -1, -1, -1, 6, NFAIL, NERRS, + $ NOUT ) + CYCLE + END IF +* + DO IMAT = 1, NTYPES +* +* Do the tests only if DOTYPE( IMAT ) is true. +* + IF( .NOT.DOTYPE( IMAT ) ) + $ CYCLE +* +* The type of distribution used to generate the random +* eigen-/singular values: +* ( 'S' for symmetric distribution ) => UNIFORM( -1, 1 ) +* +* Do for each type of NON-SYMMETRIC matrix: CNDNUM NORM MODE +* 1. Zero matrix +* 2. Random, Diagonal, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values ) +* 3. Random, Upper triangular, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values ) +* 4. Random, Lower triangular, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values ) +* 5. Random, First column is zero, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values ) +* 6. Random, Last MINMN column is zero, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values ) +* 7. Random, Last N column is zero, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values ) +* 8. Random, Middle column in MINMN is zero, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values ) +* 9. Random, First half of MINMN columns are zero, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values ) +* 10. Random, Last columns are zero starting from MINMN/2+1, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values ) +* 11. Random, Half MINMN columns in the middle are zero starting +* from MINMN/2-(MINMN/2)/2+1, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values ) +* 12. Random, Odd columns are ZERO, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values ) +* 13. Random, Even columns are ZERO, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values ) +* 14. Random, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values ) +* 15. Random, CNDNUM = sqrt(0.1/EPS) CNDNUM = BADC1 = sqrt(0.1/EPS) ONE 3 ( geometric distribution of singular values ) +* 16. Random, CNDNUM = 0.1/EPS CNDNUM = BADC2 = 0.1/EPS ONE 3 ( geometric distribution of singular values ) +* 17. Random, CNDNUM = 0.1/EPS, CNDNUM = BADC2 = 0.1/EPS ONE 2 ( one small singular value, S(N)=1/CNDNUM ) +* one small singular value S(N)=1/CNDNUM +* 18. Random, CNDNUM = 2, scaled near underflow CNDNUM = 2 SMALL = SAFMIN +* 19. Random, CNDNUM = 2, scaled near overflow CNDNUM = 2 LARGE = 1.0/( 0.25 * ( SAFMIN / EPS ) ) 3 ( geometric distribution of singular values ) +* + IF( IMAT.EQ.1 ) THEN +* +* Matrix 1: Zero matrix +* + CALL SLASET( 'Full', M, N, ZERO, ZERO, COPYA, LDA ) + DO I = 1, MINMN + S( I ) = ZERO + END DO +* + ELSE IF( (IMAT.GE.2 .AND. IMAT.LE.4 ) + $ .OR. (IMAT.GE.14 .AND. IMAT.LE.19 ) ) THEN +* +* Matrices 2-5. +* +* Set up parameters with SLATB4 and generate a test +* matrix with SLATMS. +* + CALL SLATB4( PATH, IMAT, M, N, TYPE, KL, KU, ANORM, + $ MODE, CNDNUM, DIST ) +* + SRNAMT = 'SLATMS' + CALL SLATMS( M, N, DIST, ISEED, TYPE, S, MODE, + $ CNDNUM, ANORM, KL, KU, 'No packing', + $ COPYA, LDA, WORK, INFO ) +* +* Check error code from SLATMS. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'SLATMS', INFO, 0, ' ', M, N, + $ -1, -1, -1, IMAT, NFAIL, NERRS, + $ NOUT ) + CYCLE + END IF +* + CALL SLAORD( 'Decreasing', MINMN, S, 1 ) +* + ELSE IF( MINMN.GE.2 + $ .AND. IMAT.GE.5 .AND. IMAT.LE.13 ) THEN +* +* Rectangular matrices 5-13 that contain zero columns, +* only for matrices MINMN >=2. +* +* JB_ZERO is the column index of ZERO block. +* NB_ZERO is the column block size of ZERO block. +* NB_GEN is the column blcok size of the +* generated block. +* J_INC in the non_zero column index increment +* for matrix 12 and 13. +* J_FIRS_NZ is the index of the first non-zero +* column. +* + IF( IMAT.EQ.5 ) THEN +* +* First column is zero. +* + JB_ZERO = 1 + NB_ZERO = 1 + NB_GEN = N - NB_ZERO +* + ELSE IF( IMAT.EQ.6 ) THEN +* +* Last column MINMN is zero. +* + JB_ZERO = MINMN + NB_ZERO = 1 + NB_GEN = N - NB_ZERO +* + ELSE IF( IMAT.EQ.7 ) THEN +* +* Last column N is zero. +* + JB_ZERO = N + NB_ZERO = 1 + NB_GEN = N - NB_ZERO +* + ELSE IF( IMAT.EQ.8 ) THEN +* +* Middle column in MINMN is zero. +* + JB_ZERO = MINMN / 2 + 1 + NB_ZERO = 1 + NB_GEN = N - NB_ZERO +* + ELSE IF( IMAT.EQ.9 ) THEN +* +* First half of MINMN columns is zero. +* + JB_ZERO = 1 + NB_ZERO = MINMN / 2 + NB_GEN = N - NB_ZERO +* + ELSE IF( IMAT.EQ.10 ) THEN +* +* Last columns are zero columns, +* starting from (MINMN / 2 + 1) column. +* + JB_ZERO = MINMN / 2 + 1 + NB_ZERO = N - JB_ZERO + 1 + NB_GEN = N - NB_ZERO +* + ELSE IF( IMAT.EQ.11 ) THEN +* +* Half of the columns in the middle of MINMN +* columns is zero, starting from +* MINMN/2 - (MINMN/2)/2 + 1 column. +* + JB_ZERO = MINMN / 2 - (MINMN / 2) / 2 + 1 + NB_ZERO = MINMN / 2 + NB_GEN = N - NB_ZERO +* + ELSE IF( IMAT.EQ.12 ) THEN +* +* Odd-numbered columns are zero, +* + NB_GEN = N / 2 + NB_ZERO = N - NB_GEN + J_INC = 2 + J_FIRST_NZ = 2 +* + ELSE IF( IMAT.EQ.13 ) THEN +* +* Even-numbered columns are zero. +* + NB_ZERO = N / 2 + NB_GEN = N - NB_ZERO + J_INC = 2 + J_FIRST_NZ = 1 +* + END IF +* +* +* 1) Set the first NB_ZERO columns in COPYA(1:M,1:N) +* to zero. +* + CALL SLASET( 'Full', M, NB_ZERO, ZERO, ZERO, + $ COPYA, LDA ) +* +* 2) Generate an M-by-(N-NB_ZERO) matrix with the +* chosen singular value distribution +* in COPYA(1:M,NB_ZERO+1:N). +* + CALL SLATB4( PATH, IMAT, M, NB_GEN, TYPE, KL, KU, + $ ANORM, MODE, CNDNUM, DIST ) +* + SRNAMT = 'SLATMS' +* + IND_OFFSET_GEN = NB_ZERO * LDA +* + CALL SLATMS( M, NB_GEN, DIST, ISEED, TYPE, S, MODE, + $ CNDNUM, ANORM, KL, KU, 'No packing', + $ COPYA( IND_OFFSET_GEN + 1 ), LDA, + $ WORK, INFO ) +* +* Check error code from SLATMS. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'SLATMS', INFO, 0, ' ', M, + $ NB_GEN, -1, -1, -1, IMAT, NFAIL, + $ NERRS, NOUT ) + CYCLE + END IF +* +* 3) Swap the gererated colums from the right side +* NB_GEN-size block in COPYA into correct column +* positions. +* + IF( IMAT.EQ.6 + $ .OR. IMAT.EQ.7 + $ .OR. IMAT.EQ.8 + $ .OR. IMAT.EQ.10 + $ .OR. IMAT.EQ.11 ) THEN +* +* Move by swapping the generated columns +* from the right NB_GEN-size block from +* (NB_ZERO+1:NB_ZERO+JB_ZERO) +* into columns (1:JB_ZERO-1). +* + DO J = 1, JB_ZERO-1, 1 + CALL SSWAP( M, + $ COPYA( ( NB_ZERO+J-1)*LDA+1), 1, + $ COPYA( (J-1)*LDA + 1 ), 1 ) + END DO +* + ELSE IF( IMAT.EQ.12 .OR. IMAT.EQ.13 ) THEN +* +* ( IMAT = 12, Odd-numbered ZERO columns. ) +* Swap the generated columns from the right +* NB_GEN-size block into the even zero colums in the +* left NB_ZERO-size block. +* +* ( IMAT = 13, Even-numbered ZERO columns. ) +* Swap the generated columns from the right +* NB_GEN-size block into the odd zero colums in the +* left NB_ZERO-size block. +* + DO J = 1, NB_GEN, 1 + IND_OUT = ( NB_ZERO+J-1 )*LDA + 1 + IND_IN = ( J_INC*(J-1)+(J_FIRST_NZ-1) )*LDA + $ + 1 + CALL SSWAP( M, + $ COPYA( IND_OUT ), 1, + $ COPYA( IND_IN), 1 ) + END DO +* + END IF +* +* 5) Order the singular values generated by +* DLAMTS in decreasing order and add trailing zeros +* that correspond to zero columns. +* The total number of singular values is MINMN. +* + MINMNB_GEN = MIN( M, NB_GEN ) +* + DO I = MINMNB_GEN+1, MINMN + S( I ) = ZERO + END DO +* + ELSE +* +* IF(MINMN.LT.2) skip this size for this matrix type. +* + CYCLE + END IF +* +* Initialize a copy array for a pivot array for SGEQP3RK. +* + DO I = 1, N + IWORK( I ) = 0 + END DO +* + DO INB = 1, NNB +* +* Do for each pair of values (NB,NX) in NBVAL and NXVAL. +* + NB = NBVAL( INB ) + CALL XLAENV( 1, NB ) + NX = NXVAL( INB ) + CALL XLAENV( 3, NX ) +* +* We do MIN(M,N)+1 because we need a test for KMAX > N, +* when KMAX is larger than MIN(M,N), KMAX should be +* KMAX = MIN(M,N) +* + DO KMAX = 0, MIN(M,N)+1 +* +* Get a working copy of COPYA into A( 1:M,1:N ). +* Get a working copy of COPYB into A( 1:M, (N+1):NRHS ). +* Get a working copy of COPYB into into B( 1:M, 1:NRHS ). +* Get a working copy of IWORK(1:N) awith zeroes into +* which is going to be used as pivot array IWORK( N+1:2N ). +* NOTE: IWORK(2N+1:3N) is going to be used as a WORK array +* for the routine. +* + CALL SLACPY( 'All', M, N, COPYA, LDA, A, LDA ) + CALL SLACPY( 'All', M, NRHS, COPYB, LDA, + $ A( LDA*N + 1 ), LDA ) + CALL SLACPY( 'All', M, NRHS, COPYB, LDA, + $ B, LDA ) + CALL ICOPY( N, IWORK( 1 ), 1, IWORK( N+1 ), 1 ) +* + ABSTOL = -1.0 + RELTOL = -1.0 +* +* Compute the QR factorization with pivoting of A +* + LW = MAX( 1, MAX( 2*N + NB*( N+NRHS+1 ), + $ 3*N + NRHS - 1 ) ) +* +* Compute SGEQP3RK factorization of A. +* + SRNAMT = 'SGEQP3RK' + CALL SGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, + $ A, LDA, KFACT, MAXC2NRMK, + $ RELMAXC2NRMK, IWORK( N+1 ), TAU, + $ WORK, LW, IWORK( 2*N+1 ), INFO ) +* +* Check error code from SGEQP3RK. +* + IF( INFO.LT.0 ) + $ CALL ALAERH( PATH, 'SGEQP3RK', INFO, 0, ' ', + $ M, N, NX, -1, NB, IMAT, + $ NFAIL, NERRS, NOUT ) +* +* Compute test 1: +* +* This test in only for the full rank factorization of +* the matrix A. +* +* Array S(1:min(M,N)) contains svd(A) the sigular values +* of the original matrix A in decreasing absolute value +* order. The test computes svd(R), the vector sigular +* values of the upper trapezoid of A(1:M,1:N) that +* contains the factor R, in decreasing order. The test +* returns the ratio: +* +* 2-norm(svd(R) - svd(A)) / ( max(M,N) * 2-norm(svd(A)) * EPS ) +* + IF( KFACT.EQ.MINMN ) THEN +* + RESULT( 1 ) = SQRT12( M, N, A, LDA, S, WORK, + $ LWORK ) +* + DO T = 1, 1 + IF( RESULT( T ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 ) 'SGEQP3RK', M, N, + $ NRHS, KMAX, ABSTOL, RELTOL, NB, NX, + $ IMAT, T, RESULT( T ) + NFAIL = NFAIL + 1 + END IF + END DO + NRUN = NRUN + 1 +* +* End test 1 +* + END IF +* +* Compute test 2: +* +* The test returns the ratio: +* +* 1-norm( A*P - Q*R ) / ( max(M,N) * 1-norm(A) * EPS ) +* + RESULT( 2 ) = SQPT01( M, N, KFACT, COPYA, A, LDA, TAU, + $ IWORK( N+1 ), WORK, LWORK ) +* +* Compute test 3: +* +* The test returns the ratio: +* +* 1-norm( Q**T * Q - I ) / ( M * EPS ) +* + RESULT( 3 ) = SQRT11( M, KFACT, A, LDA, TAU, WORK, + $ LWORK ) +* +* Print information about the tests that did not pass +* the threshold. +* + DO T = 2, 3 + IF( RESULT( T ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 ) 'SGEQP3RK', M, N, + $ NRHS, KMAX, ABSTOL, RELTOL, + $ NB, NX, IMAT, T, RESULT( T ) + NFAIL = NFAIL + 1 + END IF + END DO + NRUN = NRUN + 2 +* +* Compute test 4: +* +* This test is only for the factorizations with the +* rank greater than 2. +* The elements on the diagonal of R should be non- +* increasing. +* +* The test returns the ratio: +* +* Returns 1.0D+100 if abs(R(K+1,K+1)) > abs(R(K,K)), +* K=1:KFACT-1 +* + IF( MIN(KFACT, MINMN).GE.2 ) THEN +* + DO J = 1, KFACT-1, 1 + + DTEMP = (( ABS( A( (J-1)*M+J ) ) - + $ ABS( A( (J)*M+J+1 ) ) ) / + $ ABS( A(1) ) ) +* + IF( DTEMP.LT.ZERO ) THEN + RESULT( 4 ) = BIGNUM + END IF +* + END DO +* +* Print information about the tests that did not +* pass the threshold. +* + DO T = 4, 4 + IF( RESULT( T ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 ) 'SGEQP3RK', + $ M, N, NRHS, KMAX, ABSTOL, RELTOL, + $ NB, NX, IMAT, T, + $ RESULT( T ) + NFAIL = NFAIL + 1 + END IF + END DO + NRUN = NRUN + 1 +* +* End test 4. +* + END IF +* +* Compute test 5: +* +* This test in only for matrix A with min(M,N) > 0. +* +* The test returns the ratio: +* +* 1-norm(Q**T * B - Q**T * B ) / +* ( M * EPS ) +* +* (1) Compute B:=Q**T * B in the matrix B. +* + IF( MINMN.GT.0 ) THEN +* + LWORK_MQR = MAX(1, NRHS) + CALL SORMQR( 'Left', 'Transpose', + $ M, NRHS, KFACT, A, LDA, TAU, B, LDA, + $ WORK, LWORK_MQR, INFO ) +* + DO I = 1, NRHS +* +* Compare N+J-th column of A and J-column of B. +* + CALL SAXPY( M, -ONE, A( ( N+I-1 )*LDA+1 ), 1, + $ B( ( I-1 )*LDA+1 ), 1 ) + END DO +* + RESULT( 5 ) = + $ ABS( + $ SLANGE( 'One-norm', M, NRHS, B, LDA, RDUMMY ) / + $ ( REAL( M )*SLAMCH( 'Epsilon' ) ) + $ ) +* +* Print information about the tests that did not pass +* the threshold. +* + DO T = 5, 5 + IF( RESULT( T ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 ) 'SGEQP3RK', M, N, + $ NRHS, KMAX, ABSTOL, RELTOL, + $ NB, NX, IMAT, T, RESULT( T ) + NFAIL = NFAIL + 1 + END IF + END DO + NRUN = NRUN + 1 +* +* End compute test 5. +* + END IF +* +* END DO KMAX = 1, MIN(M,N)+1 +* + END DO +* +* END DO for INB = 1, NNB +* + END DO +* +* END DO for IMAT = 1, NTYPES +* + END DO +* +* END DO for INS = 1, NNS +* + END DO +* +* END DO for IN = 1, NN +* + END DO +* +* END DO for IM = 1, NM +* + END DO +* +* Print a summary of the results. +* + CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) +* + 9999 FORMAT( 1X, A, ' M =', I5, ', N =', I5, ', NRHS =', I5, + $ ', KMAX =', I5, ', ABSTOL =', G12.5, + $ ', RELTOL =', G12.5, ', NB =', I4, ', NX =', I4, + $ ', type ', I2, ', test ', I2, ', ratio =', G12.5 ) +* +* End of SCHKQP3RK +* + END diff --git a/lapack-netlib/TESTING/LIN/slatb4.f b/lapack-netlib/TESTING/LIN/slatb4.f index 94d29db40..72a310727 100644 --- a/lapack-netlib/TESTING/LIN/slatb4.f +++ b/lapack-netlib/TESTING/LIN/slatb4.f @@ -153,9 +153,6 @@ * .. Intrinsic Functions .. INTRINSIC ABS, MAX, SQRT * .. -* .. External Subroutines .. - EXTERNAL SLABAD -* .. * .. Save statement .. SAVE EPS, SMALL, LARGE, BADC1, BADC2, FIRST * .. @@ -173,11 +170,6 @@ BADC1 = SQRT( BADC2 ) SMALL = SLAMCH( 'Safe minimum' ) LARGE = ONE / SMALL -* -* If it looks like we're on a Cray, take the square root of -* SMALL and LARGE to avoid overflow and underflow problems. -* - CALL SLABAD( SMALL, LARGE ) SMALL = SHRINK*( SMALL / EPS ) LARGE = ONE / SMALL END IF @@ -232,6 +224,110 @@ ELSE ANORM = ONE END IF +* + ELSE IF( LSAMEN( 2, C2, 'QK' ) ) THEN +* +* xQK: truncated QR with pivoting. +* Set parameters to generate a general +* M x N matrix. +* +* Set TYPE, the type of matrix to be generated. 'N' is nonsymmetric. +* + TYPE = 'N' +* +* Set DIST, the type of distribution for the random +* number generator. 'S' is +* + DIST = 'S' +* +* Set the lower and upper bandwidths. +* + IF( IMAT.EQ.2 ) THEN +* +* 2. Random, Diagonal, CNDNUM = 2 +* + KL = 0 + KU = 0 + CNDNUM = TWO + ANORM = ONE + MODE = 3 + ELSE IF( IMAT.EQ.3 ) THEN +* +* 3. Random, Upper triangular, CNDNUM = 2 +* + KL = 0 + KU = MAX( N-1, 0 ) + CNDNUM = TWO + ANORM = ONE + MODE = 3 + ELSE IF( IMAT.EQ.4 ) THEN +* +* 4. Random, Lower triangular, CNDNUM = 2 +* + KL = MAX( M-1, 0 ) + KU = 0 + CNDNUM = TWO + ANORM = ONE + MODE = 3 + ELSE +* +* 5.-19. Rectangular matrix +* + KL = MAX( M-1, 0 ) + KU = MAX( N-1, 0 ) +* + IF( IMAT.GE.5 .AND. IMAT.LE.14 ) THEN +* +* 5.-14. Random, CNDNUM = 2. +* + CNDNUM = TWO + ANORM = ONE + MODE = 3 +* + ELSE IF( IMAT.EQ.15 ) THEN +* +* 15. Random, CNDNUM = sqrt(0.1/EPS) +* + CNDNUM = BADC1 + ANORM = ONE + MODE = 3 +* + ELSE IF( IMAT.EQ.16 ) THEN +* +* 16. Random, CNDNUM = 0.1/EPS +* + CNDNUM = BADC2 + ANORM = ONE + MODE = 3 +* + ELSE IF( IMAT.EQ.17 ) THEN +* +* 17. Random, CNDNUM = 0.1/EPS, +* one small singular value S(N)=1/CNDNUM +* + CNDNUM = BADC2 + ANORM = ONE + MODE = 2 +* + ELSE IF( IMAT.EQ.18 ) THEN +* +* 18. Random, scaled near underflow +* + CNDNUM = TWO + ANORM = SMALL + MODE = 3 +* + ELSE IF( IMAT.EQ.19 ) THEN +* +* 19. Random, scaled near overflow +* + CNDNUM = TWO + ANORM = LARGE + MODE = 3 +* + END IF +* + END IF * ELSE IF( LSAMEN( 2, C2, 'GE' ) ) THEN * @@ -518,17 +614,18 @@ * * Set the norm and condition number. * - IF( IMAT.EQ.2 .OR. IMAT.EQ.8 ) THEN + MAT = ABS( IMAT ) + IF( MAT.EQ.2 .OR. MAT.EQ.8 ) THEN CNDNUM = BADC1 - ELSE IF( IMAT.EQ.3 .OR. IMAT.EQ.9 ) THEN + ELSE IF( MAT.EQ.3 .OR. MAT.EQ.9 ) THEN CNDNUM = BADC2 ELSE CNDNUM = TWO END IF * - IF( IMAT.EQ.4 ) THEN + IF( MAT.EQ.4 ) THEN ANORM = SMALL - ELSE IF( IMAT.EQ.5 ) THEN + ELSE IF( MAT.EQ.5 ) THEN ANORM = LARGE ELSE ANORM = ONE diff --git a/lapack-netlib/TESTING/LIN/sqpt01.f b/lapack-netlib/TESTING/LIN/sqpt01.f index de0c80e53..f53686a65 100644 --- a/lapack-netlib/TESTING/LIN/sqpt01.f +++ b/lapack-netlib/TESTING/LIN/sqpt01.f @@ -33,7 +33,8 @@ *> Householder vectors, and the rest of AF contains a partially updated *> matrix. *> -*> This function returns ||A*P - Q*R||/(||norm(A)||*eps*M) +*> This function returns ||A*P - Q*R|| / ( ||norm(A)||*eps*max(M,N) ) +*> where || . || is matrix one norm. *> \endverbatim * * Arguments: @@ -172,28 +173,28 @@ * NORMA = SLANGE( 'One-norm', M, N, A, LDA, RWORK ) * - DO 30 J = 1, K - DO 10 I = 1, MIN( J, M ) + DO J = 1, K + DO I = 1, MIN( J, M ) WORK( ( J-1 )*M+I ) = AF( I, J ) - 10 CONTINUE - DO 20 I = J + 1, M + END DO + DO I = J + 1, M WORK( ( J-1 )*M+I ) = ZERO - 20 CONTINUE - 30 CONTINUE - DO 40 J = K + 1, N + END DO + END DO + DO J = K + 1, N CALL SCOPY( M, AF( 1, J ), 1, WORK( ( J-1 )*M+1 ), 1 ) - 40 CONTINUE + END DO * CALL SORMQR( 'Left', 'No transpose', M, N, K, AF, LDA, TAU, WORK, $ M, WORK( M*N+1 ), LWORK-M*N, INFO ) * - DO 50 J = 1, N + DO J = 1, N * * Compare i-th column of QR and jpvt(i)-th column of A * CALL SAXPY( M, -ONE, A( 1, JPVT( J ) ), 1, WORK( ( J-1 )*M+1 ), $ 1 ) - 50 CONTINUE + END DO * SQPT01 = SLANGE( 'One-norm', M, N, WORK, M, RWORK ) / $ ( REAL( MAX( M, N ) )*SLAMCH( 'Epsilon' ) ) diff --git a/lapack-netlib/TESTING/LIN/sqrt11.f b/lapack-netlib/TESTING/LIN/sqrt11.f index d4422dacb..a3753adcf 100644 --- a/lapack-netlib/TESTING/LIN/sqrt11.f +++ b/lapack-netlib/TESTING/LIN/sqrt11.f @@ -157,9 +157,9 @@ CALL SORM2R( 'Left', 'Transpose', M, M, K, A, LDA, TAU, WORK, M, $ WORK( M*M+1 ), INFO ) * - DO 10 J = 1, M + DO J = 1, M WORK( ( J-1 )*M+J ) = WORK( ( J-1 )*M+J ) - ONE - 10 CONTINUE + END DO * SQRT11 = SLANGE( 'One-norm', M, M, WORK, M, RDUMMY ) / $ ( REAL( M )*SLAMCH( 'Epsilon' ) ) diff --git a/lapack-netlib/TESTING/LIN/sqrt12.f b/lapack-netlib/TESTING/LIN/sqrt12.f index 2eab0ee0d..46b359e07 100644 --- a/lapack-netlib/TESTING/LIN/sqrt12.f +++ b/lapack-netlib/TESTING/LIN/sqrt12.f @@ -26,7 +26,7 @@ *> SQRT12 computes the singular values `svlues' of the upper trapezoid *> of A(1:M,1:N) and returns the ratio *> -*> || s - svlues||/(||svlues||*eps*max(M,N)) +*> || svlues - s ||/(||s||*eps*max(M,N)) *> \endverbatim * * Arguments: @@ -113,8 +113,7 @@ EXTERNAL SASUM, SLAMCH, SLANGE, SNRM2 * .. * .. External Subroutines .. - EXTERNAL SAXPY, SBDSQR, SGEBD2, SLABAD, SLASCL, SLASET, - $ XERBLA + EXTERNAL SAXPY, SBDSQR, SGEBD2, SLASCL, SLASET, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN, REAL @@ -145,17 +144,16 @@ * Copy upper triangle of A into work * CALL SLASET( 'Full', M, N, ZERO, ZERO, WORK, M ) - DO 20 J = 1, N - DO 10 I = 1, MIN( J, M ) + DO J = 1, N + DO I = 1, MIN( J, M ) WORK( ( J-1 )*M+I ) = A( I, J ) - 10 CONTINUE - 20 CONTINUE + END DO + END DO * * Get machine parameters * SMLNUM = SLAMCH( 'S' ) / SLAMCH( 'P' ) BIGNUM = ONE / SMLNUM - CALL SLABAD( SMLNUM, BIGNUM ) * * Scale work if max entry outside range [SMLNUM,BIGNUM] * @@ -199,9 +197,9 @@ * ELSE * - DO 30 I = 1, MN + DO I = 1, MN WORK( M*N+I ) = ZERO - 30 CONTINUE + END DO END IF * * Compare s and singular values of work diff --git a/lapack-netlib/TESTING/LIN/zchkaa.F b/lapack-netlib/TESTING/LIN/zchkaa.F index a118515a5..57d71833f 100644 --- a/lapack-netlib/TESTING/LIN/zchkaa.F +++ b/lapack-netlib/TESTING/LIN/zchkaa.F @@ -69,6 +69,7 @@ *> ZLQ 8 List types on next line if 0 < NTYPES < 8 *> ZQL 8 List types on next line if 0 < NTYPES < 8 *> ZQP 6 List types on next line if 0 < NTYPES < 6 +*> ZQK 19 List types on next line if 0 < NTYPES < 19 *> ZTZ 3 List types on next line if 0 < NTYPES < 3 *> ZLS 6 List types on next line if 0 < NTYPES < 6 *> ZEQ @@ -153,12 +154,11 @@ $ NBVAL( MAXIN ), NBVAL2( MAXIN ), $ NSVAL( MAXIN ), NVAL( MAXIN ), NXVAL( MAXIN ), $ RANKVAL( MAXIN ), PIV( NMAX ) - DOUBLE PRECISION S( 2*NMAX ) - COMPLEX*16 E( NMAX ) -* -* .. Allocatable Arrays .. +* .. +* .. Allocatable Arrays .. INTEGER AllocateStatus - DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE:: RWORK + DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE:: RWORK, S + COMPLEX*16, DIMENSION(:), ALLOCATABLE :: E COMPLEX*16, DIMENSION(:,:), ALLOCATABLE:: A, B, WORK * .. * .. External Functions .. @@ -170,15 +170,16 @@ EXTERNAL ALAREQ, ZCHKEQ, ZCHKGB, ZCHKGE, ZCHKGT, ZCHKHE, $ ZCHKHE_ROOK, ZCHKHE_RK, ZCHKHE_AA, ZCHKHP, $ ZCHKLQ, ZCHKUNHR_COL, ZCHKPB, ZCHKPO, ZCHKPS, - $ ZCHKPP, ZCHKPT, ZCHKQ3, ZCHKQL, ZCHKQR, ZCHKRQ, - $ ZCHKSP, ZCHKSY, ZCHKSY_ROOK, ZCHKSY_RK, - $ ZCHKSY_AA, ZCHKTB, ZCHKTP, ZCHKTR, ZCHKTZ, - $ ZDRVGB, ZDRVGE, ZDRVGT, ZDRVHE, ZDRVHE_ROOK, - $ ZDRVHE_RK, ZDRVHE_AA, ZDRVHE_AA_2STAGE, ZDRVHP, - $ ZDRVLS, ZDRVPB, ZDRVPO, ZDRVPP, ZDRVPT, - $ ZDRVSP, ZDRVSY, ZDRVSY_ROOK, ZDRVSY_RK, - $ ZDRVSY_AA, ZDRVSY_AA_2STAGE, ILAVER, ZCHKQRT, - $ ZCHKQRTP, ZCHKLQT, ZCHKLQTP, ZCHKTSQR + $ ZCHKPP, ZCHKPT, ZCHKQ3, ZCHKQP3RK, ZCHKQL, + $ ZCHKQR, ZCHKRQ, ZCHKSP, ZCHKSY, ZCHKSY_ROOK, + $ ZCHKSY_RK, ZCHKSY_AA, ZCHKTB, ZCHKTP, ZCHKTR, + $ ZCHKTZ, ZDRVGB, ZDRVGE, ZDRVGT, ZDRVHE, + $ ZDRVHE_ROOK, ZDRVHE_RK, ZDRVHE_AA, + $ ZDRVHE_AA_2STAGE, ZDRVHP, ZDRVLS, ZDRVPB, + $ ZDRVPO, ZDRVPP, ZDRVPT, ZDRVSP, ZDRVSY, + $ ZDRVSY_ROOK, ZDRVSY_RK, ZDRVSY_AA, + $ ZDRVSY_AA_2STAGE, ILAVER, ZCHKQRT, ZCHKQRTP, + $ ZCHKLQT, ZCHKLQTP, ZCHKTSQR * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -197,13 +198,18 @@ DATA THREQ / 2.0D0 / , INTSTR / '0123456789' / * * .. Allocate memory dynamically .. - ALLOCATE (RWORK( 150*NMAX+2*MAXRHS ), STAT = AllocateStatus) +* + ALLOCATE ( A ( (KDMAX+1) * NMAX, 7 ), STAT = AllocateStatus) + IF (AllocateStatus /= 0) STOP "*** Not enough memory ***" + ALLOCATE ( B ( NMAX * MAXRHS, 4 ), STAT = AllocateStatus) + IF (AllocateStatus /= 0 ) STOP "*** Not enough memory ***" + ALLOCATE ( WORK ( NMAX, NMAX+MAXRHS+10 ), STAT = AllocateStatus) IF (AllocateStatus /= 0) STOP "*** Not enough memory ***" - ALLOCATE (A ((KDMAX+1) * NMAX, 7), STAT = AllocateStatus) + ALLOCATE ( E( NMAX ), STAT = AllocateStatus ) IF (AllocateStatus /= 0) STOP "*** Not enough memory ***" - ALLOCATE (B (NMAX * MAXRHS, 4), STAT = AllocateStatus) + ALLOCATE ( S( 2*NMAX ), STAT = AllocateStatus) IF (AllocateStatus /= 0) STOP "*** Not enough memory ***" - ALLOCATE (WORK (NMAX, NMAX+MAXRHS+10), STAT = AllocateStatus) + ALLOCATE ( RWORK( 150*NMAX+2*MAXRHS ), STAT = AllocateStatus) IF (AllocateStatus /= 0) STOP "*** Not enough memory ***" * .. * .. Executable Statements .. @@ -1109,6 +1115,23 @@ ELSE WRITE( NOUT, FMT = 9989 )PATH END IF +* + ELSE IF( LSAMEN( 2, C2, 'QK' ) ) THEN +* +* QK: truncated QR factorization with pivoting +* + NTYPES = 19 + CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) +* + IF( TSTCHK ) THEN + CALL ZCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, + $ NNB, NBVAL, NXVAL, THRESH, A( 1, 1 ), + $ A( 1, 2 ), B( 1, 1 ), B( 1, 2 ), + $ S( 1 ), B( 1, 4 ), + $ WORK, RWORK, IWORK, NOUT ) + ELSE + WRITE( NOUT, FMT = 9989 )PATH + END IF * ELSE IF( LSAMEN( 2, C2, 'LS' ) ) THEN * diff --git a/lapack-netlib/TESTING/LIN/zchkqp3rk.f b/lapack-netlib/TESTING/LIN/zchkqp3rk.f new file mode 100644 index 000000000..302c7b1a8 --- /dev/null +++ b/lapack-netlib/TESTING/LIN/zchkqp3rk.f @@ -0,0 +1,836 @@ +*> \brief \b ZCHKQP3RK +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, +* $ NNB, NBVAL, NXVAL, THRESH, A, COPYA, +* $ B, COPYB, S, TAU, +* $ WORK, RWORK, IWORK, NOUT ) +* IMPLICIT NONE +* +* .. Scalar Arguments .. +* INTEGER NM, NN, NNB, NOUT +* DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER IWORK( * ), MVAL( * ), NBVAL( * ), NVAL( * ), +* $ NXVAL( * ) +* DOUBLE PRECISION S( * ), RWORK( * ) +* COMPLEX*16 A( * ), COPYA( * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZCHKQP3RK tests ZGEQP3RK. +*> \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] NM +*> \verbatim +*> NM is INTEGER +*> The number of values of M contained in the vector MVAL. +*> \endverbatim +*> +*> \param[in] MVAL +*> \verbatim +*> MVAL is INTEGER array, dimension (NM) +*> The values of the matrix row dimension M. +*> \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 column dimension N. +*> \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] NNB +*> \verbatim +*> NNB is INTEGER +*> The number of values of NB and NX contained in the +*> vectors NBVAL and NXVAL. The blocking parameters are used +*> in pairs (NB,NX). +*> \endverbatim +*> +*> \param[in] NBVAL +*> \verbatim +*> NBVAL is INTEGER array, dimension (NNB) +*> The values of the blocksize NB. +*> \endverbatim +*> +*> \param[in] NXVAL +*> \verbatim +*> NXVAL is INTEGER array, dimension (NNB) +*> The values of the crossover point NX. +*> \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[out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (MMAX*NMAX) +*> where MMAX is the maximum value of M in MVAL and NMAX is the +*> maximum value of N in NVAL. +*> \endverbatim +*> +*> \param[out] COPYA +*> \verbatim +*> COPYA is COMPLEX*16 array, dimension (MMAX*NMAX) +*> \endverbatim +*> +*> \param[out] B +*> \verbatim +*> B is COMPLEX*16 array, dimension (MMAX*NSMAX) +*> where MMAX is the maximum value of M in MVAL and NSMAX is the +*> maximum value of NRHS in NSVAL. +*> \endverbatim +*> +*> \param[out] COPYB +*> \verbatim +*> COPYB is COMPLEX*16 array, dimension (MMAX*NSMAX) +*> \endverbatim +*> +*> \param[out] S +*> \verbatim +*> S is DOUBLE PRECISION array, dimension +*> (min(MMAX,NMAX)) +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is COMPLEX*16 array, dimension (MMAX) +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension +*> (max(M*max(M,N) + 4*min(M,N) + max(M,N))) +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is DOUBLE PRECISION array, dimension (4*NMAX) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (2*NMAX) +*> \endverbatim +*> +*> \param[in] NOUT +*> \verbatim +*> NOUT is INTEGER +*> The unit number for output. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup complex16_lin +* +* ===================================================================== + SUBROUTINE ZCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, + $ NNB, NBVAL, NXVAL, THRESH, A, COPYA, + $ B, COPYB, S, TAU, + $ WORK, RWORK, IWORK, NOUT ) + IMPLICIT NONE +* +* -- LAPACK test routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER NM, NN, NNB, NNS, NOUT + DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER IWORK( * ), NBVAL( * ), MVAL( * ), NVAL( * ), + $ NSVAL( * ), NXVAL( * ) + DOUBLE PRECISION S( * ), RWORK( * ) + COMPLEX*16 A( * ), COPYA( * ), B( * ), COPYB( * ), + $ TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER NTYPES + PARAMETER ( NTYPES = 19 ) + INTEGER NTESTS + PARAMETER ( NTESTS = 5 ) + DOUBLE PRECISION ONE, ZERO, BIGNUM + COMPLEX*16 CONE, CZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0, + $ CZERO = ( 0.0D+0, 0.0D+0 ), + $ CONE = ( 1.0D+0, 0.0D+0 ), + $ BIGNUM = 1.0D+38 ) +* .. +* .. Local Scalars .. + CHARACTER DIST, TYPE + CHARACTER*3 PATH + INTEGER I, IHIGH, ILOW, IM, IMAT, IN, INC_ZERO, + $ INB, IND_OFFSET_GEN, + $ IND_IN, IND_OUT, INS, INFO, + $ ISTEP, J, J_INC, J_FIRST_NZ, JB_ZERO, + $ KFACT, KL, KMAX, KU, LDA, LW, LWORK, + $ LWORK_MQR, M, MINMN, MINMNB_GEN, MODE, N, + $ NB, NB_ZERO, NERRS, NFAIL, NB_GEN, NRHS, + $ NRUN, NX, T + DOUBLE PRECISION ANORM, CNDNUM, EPS, ABSTOL, RELTOL, + $ DTEMP, MAXC2NRMK, RELMAXC2NRMK +* .. +* .. Local Arrays .. + INTEGER ISEED( 4 ), ISEEDY( 4 ) + DOUBLE PRECISION RESULT( NTESTS ), RDUMMY( 1 ) +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH, ZQPT01, ZQRT11, ZQRT12, ZLANGE + EXTERNAL DLAMCH, ZQPT01, ZQRT11, ZQRT12, ZLANGE +* .. +* .. External Subroutines .. + EXTERNAL ALAERH, ALAHD, ALASUM, DLAORD, ICOPY, ZAXPY, + $ XLAENV, ZGEQP3RK, ZLACPY, ZLASET, ZLATB4, + $ ZLATMS, ZUNMQR, ZSWAP +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, MAX, MIN, MOD +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, IOUNIT, ZUNMQR_LWORK +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, IOUNIT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Data statements .. + DATA ISEEDY / 1988, 1989, 1990, 1991 / +* .. +* .. Executable Statements .. +* +* Initialize constants and the random number seed. +* + PATH( 1: 1 ) = 'Zomplex precision' + PATH( 2: 3 ) = 'QK' + NRUN = 0 + NFAIL = 0 + NERRS = 0 + DO I = 1, 4 + ISEED( I ) = ISEEDY( I ) + END DO + EPS = DLAMCH( 'Epsilon' ) + INFOT = 0 +* + DO IM = 1, NM +* +* Do for each value of M in MVAL. +* + M = MVAL( IM ) + LDA = MAX( 1, M ) +* + DO IN = 1, NN +* +* Do for each value of N in NVAL. +* + N = NVAL( IN ) + MINMN = MIN( M, N ) + LWORK = MAX( 1, M*MAX( M, N )+4*MINMN+MAX( M, N ), + $ M*N + 2*MINMN + 4*N ) +* + DO INS = 1, NNS + NRHS = NSVAL( INS ) +* +* Set up parameters with ZLATB4 and generate +* M-by-NRHS B matrix with ZLATMS. +* IMAT = 14: +* Random matrix, CNDNUM = 2, NORM = ONE, +* MODE = 3 (geometric distribution of singular values). +* + CALL ZLATB4( PATH, 14, M, NRHS, TYPE, KL, KU, ANORM, + $ MODE, CNDNUM, DIST ) +* + SRNAMT = 'ZLATMS' + CALL ZLATMS( M, NRHS, DIST, ISEED, TYPE, S, MODE, + $ CNDNUM, ANORM, KL, KU, 'No packing', + $ COPYB, LDA, WORK, INFO ) +* +* Check error code from ZLATMS. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'ZLATMS', INFO, 0, ' ', M, + $ NRHS, -1, -1, -1, 6, NFAIL, NERRS, + $ NOUT ) + CYCLE + END IF +* + DO IMAT = 1, NTYPES +* +* Do the tests only if DOTYPE( IMAT ) is true. +* + IF( .NOT.DOTYPE( IMAT ) ) + $ CYCLE +* +* The type of distribution used to generate the random +* eigen-/singular values: +* ( 'S' for symmetric distribution ) => UNIFORM( -1, 1 ) +* +* Do for each type of NON-SYMMETRIC matrix: CNDNUM NORM MODE +* 1. Zero matrix +* 2. Random, Diagonal, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values ) +* 3. Random, Upper triangular, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values ) +* 4. Random, Lower triangular, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values ) +* 5. Random, First column is zero, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values ) +* 6. Random, Last MINMN column is zero, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values ) +* 7. Random, Last N column is zero, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values ) +* 8. Random, Middle column in MINMN is zero, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values ) +* 9. Random, First half of MINMN columns are zero, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values ) +* 10. Random, Last columns are zero starting from MINMN/2+1, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values ) +* 11. Random, Half MINMN columns in the middle are zero starting +* from MINMN/2-(MINMN/2)/2+1, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values ) +* 12. Random, Odd columns are ZERO, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values ) +* 13. Random, Even columns are ZERO, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values ) +* 14. Random, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values ) +* 15. Random, CNDNUM = sqrt(0.1/EPS) CNDNUM = BADC1 = sqrt(0.1/EPS) ONE 3 ( geometric distribution of singular values ) +* 16. Random, CNDNUM = 0.1/EPS CNDNUM = BADC2 = 0.1/EPS ONE 3 ( geometric distribution of singular values ) +* 17. Random, CNDNUM = 0.1/EPS, CNDNUM = BADC2 = 0.1/EPS ONE 2 ( one small singular value, S(N)=1/CNDNUM ) +* one small singular value S(N)=1/CNDNUM +* 18. Random, CNDNUM = 2, scaled near underflow CNDNUM = 2 SMALL = SAFMIN +* 19. Random, CNDNUM = 2, scaled near overflow CNDNUM = 2 LARGE = 1.0/( 0.25 * ( SAFMIN / EPS ) ) 3 ( geometric distribution of singular values ) +* + IF( IMAT.EQ.1 ) THEN +* +* Matrix 1: Zero matrix +* + CALL ZLASET( 'Full', M, N, CZERO, CZERO, COPYA, LDA ) + DO I = 1, MINMN + S( I ) = ZERO + END DO +* + ELSE IF( (IMAT.GE.2 .AND. IMAT.LE.4 ) + $ .OR. (IMAT.GE.14 .AND. IMAT.LE.19 ) ) THEN +* +* Matrices 2-5. +* +* Set up parameters with DLATB4 and generate a test +* matrix with ZLATMS. +* + CALL ZLATB4( PATH, IMAT, M, N, TYPE, KL, KU, ANORM, + $ MODE, CNDNUM, DIST ) +* + SRNAMT = 'ZLATMS' + CALL ZLATMS( M, N, DIST, ISEED, TYPE, S, MODE, + $ CNDNUM, ANORM, KL, KU, 'No packing', + $ COPYA, LDA, WORK, INFO ) +* +* Check error code from ZLATMS. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'ZLATMS', INFO, 0, ' ', M, N, + $ -1, -1, -1, IMAT, NFAIL, NERRS, + $ NOUT ) + CYCLE + END IF +* + CALL DLAORD( 'Decreasing', MINMN, S, 1 ) +* + ELSE IF( MINMN.GE.2 + $ .AND. IMAT.GE.5 .AND. IMAT.LE.13 ) THEN +* +* Rectangular matrices 5-13 that contain zero columns, +* only for matrices MINMN >=2. +* +* JB_ZERO is the column index of ZERO block. +* NB_ZERO is the column block size of ZERO block. +* NB_GEN is the column blcok size of the +* generated block. +* J_INC in the non_zero column index increment +* for matrix 12 and 13. +* J_FIRS_NZ is the index of the first non-zero +* column. +* + IF( IMAT.EQ.5 ) THEN +* +* First column is zero. +* + JB_ZERO = 1 + NB_ZERO = 1 + NB_GEN = N - NB_ZERO +* + ELSE IF( IMAT.EQ.6 ) THEN +* +* Last column MINMN is zero. +* + JB_ZERO = MINMN + NB_ZERO = 1 + NB_GEN = N - NB_ZERO +* + ELSE IF( IMAT.EQ.7 ) THEN +* +* Last column N is zero. +* + JB_ZERO = N + NB_ZERO = 1 + NB_GEN = N - NB_ZERO +* + ELSE IF( IMAT.EQ.8 ) THEN +* +* Middle column in MINMN is zero. +* + JB_ZERO = MINMN / 2 + 1 + NB_ZERO = 1 + NB_GEN = N - NB_ZERO +* + ELSE IF( IMAT.EQ.9 ) THEN +* +* First half of MINMN columns is zero. +* + JB_ZERO = 1 + NB_ZERO = MINMN / 2 + NB_GEN = N - NB_ZERO +* + ELSE IF( IMAT.EQ.10 ) THEN +* +* Last columns are zero columns, +* starting from (MINMN / 2 + 1) column. +* + JB_ZERO = MINMN / 2 + 1 + NB_ZERO = N - JB_ZERO + 1 + NB_GEN = N - NB_ZERO +* + ELSE IF( IMAT.EQ.11 ) THEN +* +* Half of the columns in the middle of MINMN +* columns is zero, starting from +* MINMN/2 - (MINMN/2)/2 + 1 column. +* + JB_ZERO = MINMN / 2 - (MINMN / 2) / 2 + 1 + NB_ZERO = MINMN / 2 + NB_GEN = N - NB_ZERO +* + ELSE IF( IMAT.EQ.12 ) THEN +* +* Odd-numbered columns are zero, +* + NB_GEN = N / 2 + NB_ZERO = N - NB_GEN + J_INC = 2 + J_FIRST_NZ = 2 +* + ELSE IF( IMAT.EQ.13 ) THEN +* +* Even-numbered columns are zero. +* + NB_ZERO = N / 2 + NB_GEN = N - NB_ZERO + J_INC = 2 + J_FIRST_NZ = 1 +* + END IF +* +* +* 1) Set the first NB_ZERO columns in COPYA(1:M,1:N) +* to zero. +* + CALL ZLASET( 'Full', M, NB_ZERO, CZERO, CZERO, + $ COPYA, LDA ) +* +* 2) Generate an M-by-(N-NB_ZERO) matrix with the +* chosen singular value distribution +* in COPYA(1:M,NB_ZERO+1:N). +* + CALL ZLATB4( PATH, IMAT, M, NB_GEN, TYPE, KL, KU, + $ ANORM, MODE, CNDNUM, DIST ) +* + SRNAMT = 'ZLATMS' +* + IND_OFFSET_GEN = NB_ZERO * LDA +* + CALL ZLATMS( M, NB_GEN, DIST, ISEED, TYPE, S, MODE, + $ CNDNUM, ANORM, KL, KU, 'No packing', + $ COPYA( IND_OFFSET_GEN + 1 ), LDA, + $ WORK, INFO ) +* +* Check error code from ZLATMS. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'ZLATMS', INFO, 0, ' ', M, + $ NB_GEN, -1, -1, -1, IMAT, NFAIL, + $ NERRS, NOUT ) + CYCLE + END IF +* +* 3) Swap the gererated colums from the right side +* NB_GEN-size block in COPYA into correct column +* positions. +* + IF( IMAT.EQ.6 + $ .OR. IMAT.EQ.7 + $ .OR. IMAT.EQ.8 + $ .OR. IMAT.EQ.10 + $ .OR. IMAT.EQ.11 ) THEN +* +* Move by swapping the generated columns +* from the right NB_GEN-size block from +* (NB_ZERO+1:NB_ZERO+JB_ZERO) +* into columns (1:JB_ZERO-1). +* + DO J = 1, JB_ZERO-1, 1 + CALL ZSWAP( M, + $ COPYA( ( NB_ZERO+J-1)*LDA+1), 1, + $ COPYA( (J-1)*LDA + 1 ), 1 ) + END DO +* + ELSE IF( IMAT.EQ.12 .OR. IMAT.EQ.13 ) THEN +* +* ( IMAT = 12, Odd-numbered ZERO columns. ) +* Swap the generated columns from the right +* NB_GEN-size block into the even zero colums in the +* left NB_ZERO-size block. +* +* ( IMAT = 13, Even-numbered ZERO columns. ) +* Swap the generated columns from the right +* NB_GEN-size block into the odd zero colums in the +* left NB_ZERO-size block. +* + DO J = 1, NB_GEN, 1 + IND_OUT = ( NB_ZERO+J-1 )*LDA + 1 + IND_IN = ( J_INC*(J-1)+(J_FIRST_NZ-1) )*LDA + $ + 1 + CALL ZSWAP( M, + $ COPYA( IND_OUT ), 1, + $ COPYA( IND_IN), 1 ) + END DO +* + END IF +* +* 5) Order the singular values generated by +* DLAMTS in decreasing order and add trailing zeros +* that correspond to zero columns. +* The total number of singular values is MINMN. +* + MINMNB_GEN = MIN( M, NB_GEN ) +* + CALL DLAORD( 'Decreasing', MINMNB_GEN, S, 1 ) + + DO I = MINMNB_GEN+1, MINMN + S( I ) = ZERO + END DO +* + ELSE +* +* IF(MINMN.LT.2) skip this size for this matrix type. +* + CYCLE + END IF +* +* Initialize a copy array for a pivot array for DGEQP3RK. +* + DO I = 1, N + IWORK( I ) = 0 + END DO +* + DO INB = 1, NNB +* +* Do for each pair of values (NB,NX) in NBVAL and NXVAL. +* + NB = NBVAL( INB ) + CALL XLAENV( 1, NB ) + NX = NXVAL( INB ) + CALL XLAENV( 3, NX ) +* +* We do MIN(M,N)+1 because we need a test for KMAX > N, +* when KMAX is larger than MIN(M,N), KMAX should be +* KMAX = MIN(M,N) +* + DO KMAX = 0, MIN(M,N)+1 +* +* Get a working copy of COPYA into A( 1:M,1:N ). +* Get a working copy of COPYB into A( 1:M, (N+1):NRHS ). +* Get a working copy of COPYB into into B( 1:M, 1:NRHS ). +* Get a working copy of IWORK(1:N) awith zeroes into +* which is going to be used as pivot array IWORK( N+1:2N ). +* NOTE: IWORK(2N+1:3N) is going to be used as a WORK array +* for the routine. +* + CALL ZLACPY( 'All', M, N, COPYA, LDA, A, LDA ) + CALL ZLACPY( 'All', M, NRHS, COPYB, LDA, + $ A( LDA*N + 1 ), LDA ) + CALL ZLACPY( 'All', M, NRHS, COPYB, LDA, + $ B, LDA ) + CALL ICOPY( N, IWORK( 1 ), 1, IWORK( N+1 ), 1 ) +* + ABSTOL = -1.0 + RELTOl = -1.0 +* +* Compute the QR factorization with pivoting of A +* + LW = MAX( 1, MAX( 2*N + NB*( N+NRHS+1 ), + $ 3*N + NRHS - 1 ) ) +* +* Compute ZGEQP3RK factorization of A. +* + SRNAMT = 'ZGEQP3RK' + CALL ZGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, + $ A, LDA, KFACT, MAXC2NRMK, + $ RELMAXC2NRMK, IWORK( N+1 ), TAU, + $ WORK, LW, RWORK, IWORK( 2*N+1 ), + $ INFO ) +* +* Check error code from ZGEQP3RK. +* + IF( INFO.LT.0 ) + $ CALL ALAERH( PATH, 'ZGEQP3RK', INFO, 0, ' ', + $ M, N, NX, -1, NB, IMAT, + $ NFAIL, NERRS, NOUT ) +* + IF( KFACT.EQ.MINMN ) THEN +* +* Compute test 1: +* +* This test in only for the full rank factorization of +* the matrix A. +* +* Array S(1:min(M,N)) contains svd(A) the sigular values +* of the original matrix A in decreasing absolute value +* order. The test computes svd(R), the vector sigular +* values of the upper trapezoid of A(1:M,1:N) that +* contains the factor R, in decreasing order. The test +* returns the ratio: +* +* 2-norm(svd(R) - svd(A)) / ( max(M,N) * 2-norm(svd(A)) * EPS ) +* + RESULT( 1 ) = ZQRT12( M, N, A, LDA, S, WORK, + $ LWORK , RWORK ) +* + DO T = 1, 1 + IF( RESULT( T ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 ) 'ZGEQP3RK', M, N, + $ NRHS, KMAX, ABSTOL, RELTOL, NB, NX, + $ IMAT, T, RESULT( T ) + NFAIL = NFAIL + 1 + END IF + END DO + NRUN = NRUN + 1 +* +* End test 1 +* + END IF + +* Compute test 2: +* +* The test returns the ratio: +* +* 1-norm( A*P - Q*R ) / ( max(M,N) * 1-norm(A) * EPS ) +* + RESULT( 2 ) = ZQPT01( M, N, KFACT, COPYA, A, LDA, TAU, + $ IWORK( N+1 ), WORK, LWORK ) +* +* Compute test 3: +* +* The test returns the ratio: +* +* 1-norm( Q**T * Q - I ) / ( M * EPS ) +* + RESULT( 3 ) = ZQRT11( M, KFACT, A, LDA, TAU, WORK, + $ LWORK ) +* +* Print information about the tests that did not pass +* the threshold. +* + DO T = 2, 3 + IF( RESULT( T ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 ) 'ZGEQP3RK', M, N, + $ NRHS, KMAX, ABSTOL, RELTOL, + $ NB, NX, IMAT, T, RESULT( T ) + NFAIL = NFAIL + 1 + END IF + END DO + NRUN = NRUN + 2 +* +* Compute test 4: +* +* This test is only for the factorizations with the +* rank greater than 2. +* The elements on the diagonal of R should be non- +* increasing. +* +* The test returns the ratio: +* +* Returns 1.0D+100 if abs(R(K+1,K+1)) > abs(R(K,K)), +* K=1:KFACT-1 +* + IF( MIN(KFACT, MINMN).GE.2 ) THEN +* + DO J = 1, KFACT-1, 1 +* + DTEMP = (( ABS( A( (J-1)*M+J ) ) - + $ ABS( A( (J)*M+J+1 ) ) ) / + $ ABS( A(1) ) ) +* + IF( DTEMP.LT.ZERO ) THEN + RESULT( 4 ) = BIGNUM + END IF +* + END DO +* +* Print information about the tests that did not +* pass the threshold. +* + DO T = 4, 4 + IF( RESULT( T ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 ) 'ZGEQP3RK', + $ M, N, NRHS, KMAX, ABSTOL, RELTOL, + $ NB, NX, IMAT, T, + $ RESULT( T ) + NFAIL = NFAIL + 1 + END IF + END DO + NRUN = NRUN + 1 +* +* End test 4. +* + END IF +* +* Compute test 5: +* +* This test in only for matrix A with min(M,N) > 0. +* +* The test returns the ratio: +* +* 1-norm(Q**T * B - Q**T * B ) / +* ( M * EPS ) +* +* (1) Compute B:=Q**T * B in the matrix B. +* + IF( MINMN.GT.0 ) THEN +* + LWORK_MQR = MAX(1, NRHS) + CALL ZUNMQR( 'Left', 'Conjugate transpose', + $ M, NRHS, KFACT, A, LDA, TAU, B, LDA, + $ WORK, LWORK_MQR, INFO ) +* + DO I = 1, NRHS +* +* Compare N+J-th column of A and J-column of B. +* + CALL ZAXPY( M, -CONE, A( ( N+I-1 )*LDA+1 ), 1, + $ B( ( I-1 )*LDA+1 ), 1 ) + END DO +* + RESULT( 5 ) = + $ ABS( + $ ZLANGE( 'One-norm', M, NRHS, B, LDA, RDUMMY ) / + $ ( DBLE( M )*DLAMCH( 'Epsilon' ) ) + $ ) +* +* Print information about the tests that did not pass +* the threshold. +* + DO T = 5, 5 + IF( RESULT( T ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 ) 'ZGEQP3RK', M, N, + $ NRHS, KMAX, ABSTOL, RELTOL, + $ NB, NX, IMAT, T, RESULT( T ) + NFAIL = NFAIL + 1 + END IF + END DO + NRUN = NRUN + 1 +* +* End compute test 5. +* + END IF +* +* END DO KMAX = 1, MIN(M,N)+1 +* + END DO +* +* END DO for INB = 1, NNB +* + END DO +* +* END DO for IMAT = 1, NTYPES +* + END DO +* +* END DO for INS = 1, NNS +* + END DO +* +* END DO for IN = 1, NN +* + END DO +* +* END DO for IM = 1, NM +* + END DO +* +* Print a summary of the results. +* + CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) +* + 9999 FORMAT( 1X, A, ' M =', I5, ', N =', I5, ', NRHS =', I5, + $ ', KMAX =', I5, ', ABSTOL =', G12.5, + $ ', RELTOL =', G12.5, ', NB =', I4, ', NX =', I4, + $ ', type ', I2, ', test ', I2, ', ratio =', G12.5 ) +* +* End of ZCHKQP3RK +* + END diff --git a/lapack-netlib/TESTING/LIN/zlatb4.f b/lapack-netlib/TESTING/LIN/zlatb4.f index a6977f4e9..a2b19f83d 100644 --- a/lapack-netlib/TESTING/LIN/zlatb4.f +++ b/lapack-netlib/TESTING/LIN/zlatb4.f @@ -154,9 +154,6 @@ * .. Intrinsic Functions .. INTRINSIC ABS, MAX, SQRT * .. -* .. External Subroutines .. - EXTERNAL DLABAD -* .. * .. Save statement .. SAVE EPS, SMALL, LARGE, BADC1, BADC2, FIRST * .. @@ -174,11 +171,6 @@ BADC1 = SQRT( BADC2 ) SMALL = DLAMCH( 'Safe minimum' ) LARGE = ONE / SMALL -* -* If it looks like we're on a Cray, take the square root of -* SMALL and LARGE to avoid overflow and underflow problems. -* - CALL DLABAD( SMALL, LARGE ) SMALL = SHRINK*( SMALL / EPS ) LARGE = ONE / SMALL END IF @@ -233,6 +225,110 @@ ELSE ANORM = ONE END IF +* + ELSE IF( LSAMEN( 2, C2, 'QK' ) ) THEN +* +* xQK: truncated QR with pivoting. +* Set parameters to generate a general +* M x N matrix. +* +* Set TYPE, the type of matrix to be generated. 'N' is nonsymmetric. +* + TYPE = 'N' +* +* Set DIST, the type of distribution for the random +* number generator. 'S' is +* + DIST = 'S' +* +* Set the lower and upper bandwidths. +* + IF( IMAT.EQ.2 ) THEN +* +* 2. Random, Diagonal, CNDNUM = 2 +* + KL = 0 + KU = 0 + CNDNUM = TWO + ANORM = ONE + MODE = 3 + ELSE IF( IMAT.EQ.3 ) THEN +* +* 3. Random, Upper triangular, CNDNUM = 2 +* + KL = 0 + KU = MAX( N-1, 0 ) + CNDNUM = TWO + ANORM = ONE + MODE = 3 + ELSE IF( IMAT.EQ.4 ) THEN +* +* 4. Random, Lower triangular, CNDNUM = 2 +* + KL = MAX( M-1, 0 ) + KU = 0 + CNDNUM = TWO + ANORM = ONE + MODE = 3 + ELSE +* +* 5.-19. Rectangular matrix +* + KL = MAX( M-1, 0 ) + KU = MAX( N-1, 0 ) +* + IF( IMAT.GE.5 .AND. IMAT.LE.14 ) THEN +* +* 5.-14. Random, CNDNUM = 2. +* + CNDNUM = TWO + ANORM = ONE + MODE = 3 +* + ELSE IF( IMAT.EQ.15 ) THEN +* +* 15. Random, CNDNUM = sqrt(0.1/EPS) +* + CNDNUM = BADC1 + ANORM = ONE + MODE = 3 +* + ELSE IF( IMAT.EQ.16 ) THEN +* +* 16. Random, CNDNUM = 0.1/EPS +* + CNDNUM = BADC2 + ANORM = ONE + MODE = 3 +* + ELSE IF( IMAT.EQ.17 ) THEN +* +* 17. Random, CNDNUM = 0.1/EPS, +* one small singular value S(N)=1/CNDNUM +* + CNDNUM = BADC2 + ANORM = ONE + MODE = 2 +* + ELSE IF( IMAT.EQ.18 ) THEN +* +* 18. Random, scaled near underflow +* + CNDNUM = TWO + ANORM = SMALL + MODE = 3 +* + ELSE IF( IMAT.EQ.19 ) THEN +* +* 19. Random, scaled near overflow +* + CNDNUM = TWO + ANORM = LARGE + MODE = 3 +* + END IF +* + END IF * ELSE IF( LSAMEN( 2, C2, 'GE' ) ) THEN * @@ -517,17 +613,18 @@ * * Set the norm and condition number. * - IF( IMAT.EQ.2 .OR. IMAT.EQ.8 ) THEN + MAT = ABS( IMAT ) + IF( MAT.EQ.2 .OR. MAT.EQ.8 ) THEN CNDNUM = BADC1 - ELSE IF( IMAT.EQ.3 .OR. IMAT.EQ.9 ) THEN + ELSE IF( MAT.EQ.3 .OR. MAT.EQ.9 ) THEN CNDNUM = BADC2 ELSE CNDNUM = TWO END IF * - IF( IMAT.EQ.4 ) THEN + IF( MAT.EQ.4 ) THEN ANORM = SMALL - ELSE IF( IMAT.EQ.5 ) THEN + ELSE IF( MAT.EQ.5 ) THEN ANORM = LARGE ELSE ANORM = ONE diff --git a/lapack-netlib/TESTING/LIN/zqpt01.f b/lapack-netlib/TESTING/LIN/zqpt01.f index 4e53f92c8..c69eb658f 100644 --- a/lapack-netlib/TESTING/LIN/zqpt01.f +++ b/lapack-netlib/TESTING/LIN/zqpt01.f @@ -33,7 +33,7 @@ *> Householder vectors, and the rest of AF contains a partially updated *> matrix. *> -*> This function returns ||A*P - Q*R||/(||norm(A)||*eps*M) +*> This function returns ||A*P - Q*R|| / ( ||norm(A)||*eps*max(M,N) ) *> \endverbatim * * Arguments: @@ -172,28 +172,28 @@ * NORMA = ZLANGE( 'One-norm', M, N, A, LDA, RWORK ) * - DO 30 J = 1, K - DO 10 I = 1, MIN( J, M ) + DO J = 1, K + DO I = 1, MIN( J, M ) WORK( ( J-1 )*M+I ) = AF( I, J ) - 10 CONTINUE - DO 20 I = J + 1, M + END DO + DO I = J + 1, M WORK( ( J-1 )*M+I ) = ZERO - 20 CONTINUE - 30 CONTINUE - DO 40 J = K + 1, N + END DO + END DO + DO J = K + 1, N CALL ZCOPY( M, AF( 1, J ), 1, WORK( ( J-1 )*M+1 ), 1 ) - 40 CONTINUE + END DO * CALL ZUNMQR( 'Left', 'No transpose', M, N, K, AF, LDA, TAU, WORK, $ M, WORK( M*N+1 ), LWORK-M*N, INFO ) * - DO 50 J = 1, N + DO J = 1, N * * Compare i-th column of QR and jpvt(i)-th column of A * CALL ZAXPY( M, DCMPLX( -ONE ), A( 1, JPVT( J ) ), 1, $ WORK( ( J-1 )*M+1 ), 1 ) - 50 CONTINUE + END DO * ZQPT01 = ZLANGE( 'One-norm', M, N, WORK, M, RWORK ) / $ ( DBLE( MAX( M, N ) )*DLAMCH( 'Epsilon' ) ) diff --git a/lapack-netlib/TESTING/LIN/zqrt11.f b/lapack-netlib/TESTING/LIN/zqrt11.f index c3be59c36..dc4af744f 100644 --- a/lapack-netlib/TESTING/LIN/zqrt11.f +++ b/lapack-netlib/TESTING/LIN/zqrt11.f @@ -158,9 +158,9 @@ CALL ZUNM2R( 'Left', 'Conjugate transpose', M, M, K, A, LDA, TAU, $ WORK, M, WORK( M*M+1 ), INFO ) * - DO 10 J = 1, M + DO J = 1, M WORK( ( J-1 )*M+J ) = WORK( ( J-1 )*M+J ) - ONE - 10 CONTINUE + END DO * ZQRT11 = ZLANGE( 'One-norm', M, M, WORK, M, RDUMMY ) / $ ( DBLE( M )*DLAMCH( 'Epsilon' ) ) diff --git a/lapack-netlib/TESTING/LIN/zqrt12.f b/lapack-netlib/TESTING/LIN/zqrt12.f index 0da6be157..91477b5ea 100644 --- a/lapack-netlib/TESTING/LIN/zqrt12.f +++ b/lapack-netlib/TESTING/LIN/zqrt12.f @@ -28,7 +28,7 @@ *> ZQRT12 computes the singular values `svlues' of the upper trapezoid *> of A(1:M,1:N) and returns the ratio *> -*> || s - svlues||/(||svlues||*eps*max(M,N)) +*> || svlues - s||/(||s||*eps*max(M,N)) *> \endverbatim * * Arguments: @@ -125,8 +125,8 @@ EXTERNAL DASUM, DLAMCH, DNRM2, ZLANGE * .. * .. External Subroutines .. - EXTERNAL DAXPY, DBDSQR, DLABAD, DLASCL, XERBLA, ZGEBD2, - $ ZLASCL, ZLASET + EXTERNAL DAXPY, DBDSQR, DLASCL, XERBLA, ZGEBD2, ZLASCL, + $ ZLASET * .. * .. Intrinsic Functions .. INTRINSIC DBLE, DCMPLX, MAX, MIN @@ -154,17 +154,16 @@ * CALL ZLASET( 'Full', M, N, DCMPLX( ZERO ), DCMPLX( ZERO ), WORK, $ M ) - DO 20 J = 1, N - DO 10 I = 1, MIN( J, M ) + DO J = 1, N + DO I = 1, MIN( J, M ) WORK( ( J-1 )*M+I ) = A( I, J ) - 10 CONTINUE - 20 CONTINUE + END DO + END DO * * Get machine parameters * SMLNUM = DLAMCH( 'S' ) / DLAMCH( 'P' ) BIGNUM = ONE / SMLNUM - CALL DLABAD( SMLNUM, BIGNUM ) * * Scale work if max entry outside range [SMLNUM,BIGNUM] * @@ -208,9 +207,9 @@ * ELSE * - DO 30 I = 1, MN + DO I = 1, MN RWORK( I ) = ZERO - 30 CONTINUE + END DO END IF * * Compare s and singular values of work @@ -218,6 +217,7 @@ CALL DAXPY( MN, -ONE, S, 1, RWORK( 1 ), 1 ) ZQRT12 = DASUM( MN, RWORK( 1 ), 1 ) / $ ( DLAMCH( 'Epsilon' )*DBLE( MAX( M, N ) ) ) +* IF( NRMSVL.NE.ZERO ) $ ZQRT12 = ZQRT12 / NRMSVL * From 0eb8a87977531b50a70011bad39f90ae57953e06 Mon Sep 17 00:00:00 2001 From: Martin Kroeker Date: Wed, 15 Nov 2023 09:56:37 +0100 Subject: [PATCH 06/60] Implement truncated QR with pivoting (Reference-LAPACK PR 891) --- lapack-netlib/TESTING/ctest.in | 1 + lapack-netlib/TESTING/dtest.in | 1 + lapack-netlib/TESTING/stest.in | 1 + lapack-netlib/TESTING/ztest.in | 1 + 4 files changed, 4 insertions(+) diff --git a/lapack-netlib/TESTING/ctest.in b/lapack-netlib/TESTING/ctest.in index a3588b4a1..74ff31ab8 100644 --- a/lapack-netlib/TESTING/ctest.in +++ b/lapack-netlib/TESTING/ctest.in @@ -42,6 +42,7 @@ CRQ 8 List types on next line if 0 < NTYPES < 8 CLQ 8 List types on next line if 0 < NTYPES < 8 CQL 8 List types on next line if 0 < NTYPES < 8 CQP 6 List types on next line if 0 < NTYPES < 6 +CQK 19 List types on next line if 0 < NTYPES < 19 CTZ 3 List types on next line if 0 < NTYPES < 3 CLS 6 List types on next line if 0 < NTYPES < 6 CEQ diff --git a/lapack-netlib/TESTING/dtest.in b/lapack-netlib/TESTING/dtest.in index 29bb8b92e..1b6c7bd4a 100644 --- a/lapack-netlib/TESTING/dtest.in +++ b/lapack-netlib/TESTING/dtest.in @@ -36,6 +36,7 @@ DRQ 8 List types on next line if 0 < NTYPES < 8 DLQ 8 List types on next line if 0 < NTYPES < 8 DQL 8 List types on next line if 0 < NTYPES < 8 DQP 6 List types on next line if 0 < NTYPES < 6 +DQK 19 LIst types on next line if 0 < NTYPES < 19 DTZ 3 List types on next line if 0 < NTYPES < 3 DLS 6 List types on next line if 0 < NTYPES < 6 DEQ diff --git a/lapack-netlib/TESTING/stest.in b/lapack-netlib/TESTING/stest.in index 27ac30040..7faa8b7a1 100644 --- a/lapack-netlib/TESTING/stest.in +++ b/lapack-netlib/TESTING/stest.in @@ -36,6 +36,7 @@ SRQ 8 List types on next line if 0 < NTYPES < 8 SLQ 8 List types on next line if 0 < NTYPES < 8 SQL 8 List types on next line if 0 < NTYPES < 8 SQP 6 List types on next line if 0 < NTYPES < 6 +SQK 19 List types on next line if 0 < NTYPES < 19 STZ 3 List types on next line if 0 < NTYPES < 3 SLS 6 List types on next line if 0 < NTYPES < 6 SEQ diff --git a/lapack-netlib/TESTING/ztest.in b/lapack-netlib/TESTING/ztest.in index 58da33d60..c83e82e45 100644 --- a/lapack-netlib/TESTING/ztest.in +++ b/lapack-netlib/TESTING/ztest.in @@ -42,6 +42,7 @@ ZRQ 8 List types on next line if 0 < NTYPES < 8 ZLQ 8 List types on next line if 0 < NTYPES < 8 ZQL 8 List types on next line if 0 < NTYPES < 8 ZQP 6 List types on next line if 0 < NTYPES < 6 +ZQK 19 List types on next line if 0 < NTYPES < 19 ZTZ 3 List types on next line if 0 < NTYPES < 3 ZLS 6 List types on next line if 0 < NTYPES < 6 ZEQ From 5bf87c86f580982d741d3870740364659f99a4af Mon Sep 17 00:00:00 2001 From: Martin Kroeker Date: Wed, 15 Nov 2023 12:10:20 +0100 Subject: [PATCH 07/60] Implement truncated QR with pivoting (Reference-LAPACK PR 891) --- cmake/lapack.cmake | 32 ++++++++++++++++---------------- 1 file changed, 16 insertions(+), 16 deletions(-) diff --git a/cmake/lapack.cmake b/cmake/lapack.cmake index 22476f561..003a8b3c1 100644 --- a/cmake/lapack.cmake +++ b/cmake/lapack.cmake @@ -52,7 +52,7 @@ set(SLASRC sgebrd.f sgecon.f sgeequ.f sgees.f sgeesx.f sgeev.f sgeevx.f sgehd2.f sgehrd.f sgelq2.f sgelqf.f sgels.f sgelsd.f sgelss.f sgelsy.f sgeql2.f sgeqlf.f - sgeqp3.f sgeqr2.f sgeqr2p.f sgeqrf.f sgeqrfp.f sgerfs.f sgerq2.f sgerqf.f + sgeqp3.f sgeqp3rk.f sgeqr2.f sgeqr2p.f sgeqrf.f sgeqrfp.f sgerfs.f sgerq2.f sgerqf.f sgesc2.f sgesdd.f sgesvd.f sgesvdx.f sgesvx.f sgetc2.f sgetrf2.f sgetri.f sggbak.f sggbal.f @@ -67,7 +67,7 @@ set(SLASRC slangb.f slange.f slangt.f slanhs.f slansb.f slansp.f slansy.f slantb.f slantp.f slantr.f slanv2.f slapll.f slapmt.f - slaqgb.f slaqge.f slaqp2.f slaqps.f slaqsb.f slaqsp.f slaqsy.f + slaqgb.f slaqge.f slaqp2.f slaqps.f slaqp2rk.f slaqp3rk.f slaqsb.f slaqsp.f slaqsy.f slaqr0.f slaqr1.f slaqr2.f slaqr3.f slaqr4.f slaqr5.f slaqtr.f slar1v.f slar2v.f ilaslr.f ilaslc.f slarf.f slarfb.f slarfb_gett.f slarfg.f slarfgp.f slarft.f slarfx.f slarfy.f slargv.f @@ -139,7 +139,7 @@ set(CLASRC cgbtf2.f cgbtrf.f cgbtrs.f cgebak.f cgebal.f cgebd2.f cgebrd.f cgecon.f cgeequ.f cgees.f cgeesx.f cgeev.f cgeevx.f cgehd2.f cgehrd.f cgelq2.f cgelqf.f - cgels.f cgelsd.f cgelss.f cgelsy.f cgeql2.f cgeqlf.f cgeqp3.f + cgels.f cgelsd.f cgelss.f cgelsy.f cgeql2.f cgeqlf.f cgeqp3.f cgeqp3rk.f cgeqr2.f cgeqr2p.f cgeqrf.f cgeqrfp.f cgerfs.f cgerq2.f cgerqf.f cgesc2.f cgesdd.f cgesvd.f cgesvdx.f cgesvj.f cgejsv.f cgsvj0.f cgsvj1.f @@ -173,7 +173,7 @@ set(CLASRC clanhb.f clanhe.f clanhp.f clanhs.f clanht.f clansb.f clansp.f clansy.f clantb.f clantp.f clantr.f clapll.f clapmt.f clarcm.f claqgb.f claqge.f - claqhb.f claqhe.f claqhp.f claqp2.f claqps.f claqsb.f + claqhb.f claqhe.f claqhp.f claqp2.f claqps.f claqp2rk.f claqp3rk.f claqsb.f claqr0.f claqr1.f claqr2.f claqr3.f claqr4.f claqr5.f claqz0.f claqz1.f claqz2.f claqz3.f claqsp.f claqsy.f clar1v.f clar2v.f ilaclr.f ilaclc.f @@ -243,7 +243,7 @@ set(DLASRC dgebrd.f dgecon.f dgeequ.f dgees.f dgeesx.f dgeev.f dgeevx.f dgehd2.f dgehrd.f dgelq2.f dgelqf.f dgels.f dgelsd.f dgelss.f dgelsy.f dgeql2.f dgeqlf.f - dgeqp3.f dgeqr2.f dgeqr2p.f dgeqrf.f dgeqrfp.f dgerfs.f dgerq2.f dgerqf.f + dgeqp3.f dgeqp3rk.f dgeqr2.f dgeqr2p.f dgeqrf.f dgeqrfp.f dgerfs.f dgerq2.f dgerqf.f dgesc2.f dgesdd.f dgesvd.f dgesvdx.f dgesvx.f dgetc2.f dgetrf2.f dgetri.f dggbak.f dggbal.f @@ -258,7 +258,7 @@ set(DLASRC dlangb.f dlange.f dlangt.f dlanhs.f dlansb.f dlansp.f dlansy.f dlantb.f dlantp.f dlantr.f dlanv2.f dlapll.f dlapmt.f - dlaqgb.f dlaqge.f dlaqp2.f dlaqps.f dlaqsb.f dlaqsp.f dlaqsy.f + dlaqgb.f dlaqge.f dlaqp2.f dlaqp2rk.f dlaqp3rk.f dlaqps.f dlaqsb.f dlaqsp.f dlaqsy.f dlaqr0.f dlaqr1.f dlaqr2.f dlaqr3.f dlaqr4.f dlaqr5.f dlaqtr.f dlar1v.f dlar2v.f iladlr.f iladlc.f dlarf.f dlarfb.f dlarfb_gett.f dlarfg.f dlarfgp.f dlarft.f dlarfx.f dlarfy.f @@ -331,7 +331,7 @@ set(ZLASRC zgbtf2.f zgbtrf.f zgbtrs.f zgebak.f zgebal.f zgebd2.f zgebrd.f zgecon.f zgeequ.f zgees.f zgeesx.f zgeev.f zgeevx.f zgehd2.f zgehrd.f zgelq2.f zgelqf.f - zgels.f zgelsd.f zgelss.f zgelsy.f zgeql2.f zgeqlf.f zgeqp3.f + zgels.f zgelsd.f zgelss.f zgelsy.f zgeql2.f zgeqlf.f zgeqp3.f zgeqp3rk.f zgeqr2.f zgeqr2p.f zgeqrf.f zgeqrfp.f zgerfs.f zgerq2.f zgerqf.f zgesc2.f zgesdd.f zgesvd.f zgesvdx.f zgesvx.f zgesvj.f zgejsv.f zgsvj0.f zgsvj1.f @@ -367,7 +367,7 @@ set(ZLASRC zlanhe.f zlanhp.f zlanhs.f zlanht.f zlansb.f zlansp.f zlansy.f zlantb.f zlantp.f zlantr.f zlapll.f zlapmt.f zlaqgb.f zlaqge.f - zlaqhb.f zlaqhe.f zlaqhp.f zlaqp2.f zlaqps.f zlaqsb.f + zlaqhb.f zlaqhe.f zlaqhp.f zlaqp2.f zlaqp2rk.f zlaqp3rk.f zlaqps.f zlaqsb.f zlaqr0.f zlaqr1.f zlaqr2.f zlaqr3.f zlaqr4.f zlaqr5.f zlaqsp.f zlaqsy.f zlar1v.f zlar2v.f ilazlr.f ilazlc.f zlarcm.f zlarf.f zlarfb.f zlarfb_gett.f @@ -557,7 +557,7 @@ set(SLASRC sgebrd.c sgecon.c sgeequ.c sgees.c sgeesx.c sgeev.c sgeevx.c sgehd2.c sgehrd.c sgelq2.c sgelqf.c sgels.c sgelsd.c sgelss.c sgelsy.c sgeql2.c sgeqlf.c - sgeqp3.c sgeqr2.c sgeqr2p.c sgeqrf.c sgeqrfp.c sgerfs.c sgerq2.c sgerqf.c + sgeqp3.c sgeqp3rk.c sgeqr2.c sgeqr2p.c sgeqrf.c sgeqrfp.c sgerfs.c sgerq2.c sgerqf.c sgesc2.c sgesdd.c sgesvd.c sgesvdx.c sgesvx.c sgetc2.c sgetrf2.c sgetri.c sggbak.c sggbal.c @@ -571,7 +571,7 @@ set(SLASRC slangb.c slange.c slangt.c slanhs.c slansb.c slansp.c slansy.c slantb.c slantp.c slantr.c slanv2.c slapll.c slapmt.c - slaqgb.c slaqge.c slaqp2.c slaqps.c slaqsb.c slaqsp.c slaqsy.c + slaqgb.c slaqge.c slaqp2.c slaqp2rk.c slaqp3rk.c slaqps.c slaqsb.c slaqsp.c slaqsy.c slaqr0.c slaqr1.c slaqr2.c slaqr3.c slaqr4.c slaqr5.c slaqtr.c slar1v.c slar2v.c ilaslr.c ilaslc.c slarf.c slarfb.c slarfb_gett.c slarfg.c slarfgp.c slarft.c slarfx.c slarfy.c slargv.c @@ -643,7 +643,7 @@ set(CLASRC cgbtf2.c cgbtrf.c cgbtrs.c cgebak.c cgebal.c cgebd2.c cgebrd.c cgecon.c cgeequ.c cgees.c cgeesx.c cgeev.c cgeevx.c cgehd2.c cgehrd.c cgelq2.c cgelqf.c - cgels.c cgelsd.c cgelss.c cgelsy.c cgeql2.c cgeqlf.c cgeqp3.c + cgels.c cgelsd.c cgelss.c cgelsy.c cgeql2.c cgeqlf.c cgeqp3.c cgeqp3rk.c cgeqr2.c cgeqr2p.c cgeqrf.c cgeqrfp.c cgerfs.c cgerq2.c cgerqf.c cgesc2.c cgesdd.c cgesvd.c cgesvdx.c cgesvj.c cgejsv.c cgsvj0.c cgsvj1.c @@ -677,7 +677,7 @@ set(CLASRC clanhb.c clanhe.c clanhp.c clanhs.c clanht.c clansb.c clansp.c clansy.c clantb.c clantp.c clantr.c clapll.c clapmt.c clarcm.c claqgb.c claqge.c - claqhb.c claqhe.c claqhp.c claqp2.c claqps.c claqsb.c + claqhb.c claqhe.c claqhp.c claqp2.c claqp2rk.c claqp3rk.c claqps.c claqsb.c claqr0.c claqr1.c claqr2.c claqr3.c claqr4.c claqr5.c claqsp.c claqsy.c clar1v.c clar2v.c ilaclr.c ilaclc.c clarf.c clarfb.c clarfb_gett.c clarfg.c clarfgp.c clarft.c @@ -746,7 +746,7 @@ set(DLASRC dgebrd.c dgecon.c dgeequ.c dgees.c dgeesx.c dgeev.c dgeevx.c dgehd2.c dgehrd.c dgelq2.c dgelqf.c dgels.c dgelsd.c dgelss.c dgelsy.c dgeql2.c dgeqlf.c - dgeqp3.c dgeqr2.c dgeqr2p.c dgeqrf.c dgeqrfp.c dgerfs.c dgerq2.c dgerqf.c + dgeqp3.c dgeqp3rk.c dgeqr2.c dgeqr2p.c dgeqrf.c dgeqrfp.c dgerfs.c dgerq2.c dgerqf.c dgesc2.c dgesdd.c dgesvd.c dgesvdx.c dgesvx.c dgetc2.c dgetrf2.c dgetri.c dggbak.c dggbal.c @@ -760,7 +760,7 @@ set(DLASRC dlangb.c dlange.c dlangt.c dlanhs.c dlansb.c dlansp.c dlansy.c dlantb.c dlantp.c dlantr.c dlanv2.c dlapll.c dlapmt.c - dlaqgb.c dlaqge.c dlaqp2.c dlaqps.c dlaqsb.c dlaqsp.c dlaqsy.c + dlaqgb.c dlaqge.c dlaqp2.c dlaqp2rk.c dlaqp3rk.c dlaqps.c dlaqsb.c dlaqsp.c dlaqsy.c dlaqr0.c dlaqr1.c dlaqr2.c dlaqr3.c dlaqr4.c dlaqr5.c dlaqtr.c dlar1v.c dlar2v.c iladlr.c iladlc.c dlarf.c dlarfb.c dlarfb_gett.c dlarfg.c dlarfgp.c dlarft.c dlarfx.c dlarfy.c @@ -833,7 +833,7 @@ set(ZLASRC zgbtf2.c zgbtrf.c zgbtrs.c zgebak.c zgebal.c zgebd2.c zgebrd.c zgecon.c zgeequ.c zgees.c zgeesx.c zgeev.c zgeevx.c zgehd2.c zgehrd.c zgelq2.c zgelqf.c - zgels.c zgelsd.c zgelss.c zgelsy.c zgeql2.c zgeqlf.c zgeqp3.c + zgels.c zgelsd.c zgelss.c zgelsy.c zgeql2.c zgeqlf.c zgeqp3.c zgeqp3rk.c zgeqr2.c zgeqr2p.c zgeqrf.c zgeqrfp.c zgerfs.c zgerq2.c zgerqf.c zgesc2.c zgesdd.c zgesvd.c zgesvdx.c zgesvx.c zgesvj.c zgejsv.c zgsvj0.c zgsvj1.c @@ -868,7 +868,7 @@ set(ZLASRC zlanhe.c zlanhp.c zlanhs.c zlanht.c zlansb.c zlansp.c zlansy.c zlantb.c zlantp.c zlantr.c zlapll.c zlapmt.c zlaqgb.c zlaqge.c - zlaqhb.c zlaqhe.c zlaqhp.c zlaqp2.c zlaqps.c zlaqsb.c + zlaqhb.c zlaqhe.c zlaqhp.c zlaqp2.c zlaqp2rk.c zlaqp3rk.c zlaqps.c zlaqsb.c zlaqr0.c zlaqr1.c zlaqr2.c zlaqr3.c zlaqr4.c zlaqr5.c zlaqsp.c zlaqsy.c zlar1v.c zlar2v.c ilazlr.c ilazlc.c zlarcm.c zlarf.c zlarfb.c zlarfb_gett.c From f437339130a7e3878a94b2a2ea87edbdd05ba5cf Mon Sep 17 00:00:00 2001 From: Martin Kroeker Date: Wed, 15 Nov 2023 12:12:26 +0100 Subject: [PATCH 08/60] Implement truncated QR with pivoting (Reference-LAPACK PR 891) --- lapack-netlib/SRC/cgeqp3rk.c | 1071 +++++++++++++++++++++++++++++++ lapack-netlib/SRC/claqp2rk.c | 943 +++++++++++++++++++++++++++ lapack-netlib/SRC/claqp3rk.c | 1152 +++++++++++++++++++++++++++++++++ lapack-netlib/SRC/dgeqp3rk.c | 1059 +++++++++++++++++++++++++++++++ lapack-netlib/SRC/dlaqp2rk.c | 923 +++++++++++++++++++++++++++ lapack-netlib/SRC/dlaqp3rk.c | 1113 ++++++++++++++++++++++++++++++++ lapack-netlib/SRC/sgeqp3rk.c | 1055 +++++++++++++++++++++++++++++++ lapack-netlib/SRC/slaqp2rk.c | 918 +++++++++++++++++++++++++++ lapack-netlib/SRC/slaqp3rk.c | 1109 ++++++++++++++++++++++++++++++++ lapack-netlib/SRC/zgeqp3rk.c | 1074 +++++++++++++++++++++++++++++++ lapack-netlib/SRC/zlaqp2rk.c | 947 ++++++++++++++++++++++++++++ lapack-netlib/SRC/zlaqp3rk.c | 1157 ++++++++++++++++++++++++++++++++++ 12 files changed, 12521 insertions(+) create mode 100644 lapack-netlib/SRC/cgeqp3rk.c create mode 100644 lapack-netlib/SRC/claqp2rk.c create mode 100644 lapack-netlib/SRC/claqp3rk.c create mode 100644 lapack-netlib/SRC/dgeqp3rk.c create mode 100644 lapack-netlib/SRC/dlaqp2rk.c create mode 100644 lapack-netlib/SRC/dlaqp3rk.c create mode 100644 lapack-netlib/SRC/sgeqp3rk.c create mode 100644 lapack-netlib/SRC/slaqp2rk.c create mode 100644 lapack-netlib/SRC/slaqp3rk.c create mode 100644 lapack-netlib/SRC/zgeqp3rk.c create mode 100644 lapack-netlib/SRC/zlaqp2rk.c create mode 100644 lapack-netlib/SRC/zlaqp3rk.c diff --git a/lapack-netlib/SRC/cgeqp3rk.c b/lapack-netlib/SRC/cgeqp3rk.c new file mode 100644 index 000000000..54e7fb140 --- /dev/null +++ b/lapack-netlib/SRC/cgeqp3rk.c @@ -0,0 +1,1071 @@ +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +#if defined(_WIN64) +typedef long long BLASLONG; +typedef unsigned long long BLASULONG; +#else +typedef long BLASLONG; +typedef unsigned long BLASULONG; +#endif + +#ifdef LAPACK_ILP64 +typedef BLASLONG blasint; +#if defined(_WIN64) +#define blasabs(x) llabs(x) +#else +#define blasabs(x) labs(x) +#endif +#else +typedef int blasint; +#define blasabs(x) abs(x) +#endif + +typedef blasint integer; + +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +#ifdef _MSC_VER +static inline _Fcomplex Cf(complex *z) {_Fcomplex zz={z->r , z->i}; return zz;} +static inline _Dcomplex Cd(doublecomplex *z) {_Dcomplex zz={z->r , z->i};return zz;} +static inline _Fcomplex * _pCf(complex *z) {return (_Fcomplex*)z;} +static inline _Dcomplex * _pCd(doublecomplex *z) {return (_Dcomplex*)z;} +#else +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#endif +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#ifdef _MSC_VER +#define c_div(c, a, b) {Cf(c)._Val[0] = (Cf(a)._Val[0]/Cf(b)._Val[0]); Cf(c)._Val[1]=(Cf(a)._Val[1]/Cf(b)._Val[1]);} +#define z_div(c, a, b) {Cd(c)._Val[0] = (Cd(a)._Val[0]/Cd(b)._Val[0]); Cd(c)._Val[1]=(Cd(a)._Val[1]/Cd(b)._Val[1]);} +#else +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#endif +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conjf(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimagf(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) {ceil(w)} +#define myhuge_(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +#ifdef _MSC_VER +static _Fcomplex cpow_ui(complex x, integer n) { + complex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x.r = 1/x.r, x.i=1/x.i; + for(u = n; ; ) { + if(u & 01) pow.r *= x.r, pow.i *= x.i; + if(u >>= 1) x.r *= x.r, x.i *= x.i; + else break; + } + } + _Fcomplex p={pow.r, pow.i}; + return p; +} +#else +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +#endif +#ifdef _MSC_VER +static _Dcomplex zpow_ui(_Dcomplex x, integer n) { + _Dcomplex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x._Val[0] = 1/x._Val[0], x._Val[1] =1/x._Val[1]; + for(u = n; ; ) { + if(u & 01) pow._Val[0] *= x._Val[0], pow._Val[1] *= x._Val[1]; + if(u >>= 1) x._Val[0] *= x._Val[0], x._Val[1] *= x._Val[1]; + else break; + } + } + _Dcomplex p = {pow._Val[0], pow._Val[1]}; + return p; +} +#else +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +#endif +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; +#ifdef _MSC_VER + _Fcomplex zdotc = {0.0, 0.0}; + if (incx == 1 && incy == 1) { + for (i=0;i myhugeval) { + +/* Check if the matrix A contains +Inf or -Inf, set INFO parameter */ +/* to the column number, where the first +/-Inf is found plus N, */ +/* and continue the computation. */ + + *info = *n + kp1; + + } + +/* ================================================================== */ + +/* Quick return if possible for the case when the first */ +/* stopping criterion is satisfied, i.e. KMAX = 0. */ + + if (*kmax == 0) { + *k = 0; + *maxc2nrmk = maxc2nrm; + *relmaxc2nrmk = 1.f; + i__1 = minmn; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + tau[i__2].r = 0.f, tau[i__2].i = 0.f; + } + q__1.r = (real) lwkopt, q__1.i = 0.f; + work[1].r = q__1.r, work[1].i = q__1.i; + return 0; + } + +/* ================================================================== */ + + eps = slamch_("Epsilon"); + +/* Adjust ABSTOL */ + + if (*abstol >= 0.f) { + safmin = slamch_("Safe minimum"); +/* Computing MAX */ + r__1 = *abstol, r__2 = safmin * 2.f; + *abstol = f2cmax(r__1,r__2); + } + +/* Adjust RELTOL */ + + if (*reltol >= 0.f) { + *reltol = f2cmax(*reltol,eps); + } + +/* =================================================================== */ + +/* JMAX is the maximum index of the column to be factorized, */ +/* which is also limited by the first stopping criterion KMAX. */ + + jmax = f2cmin(*kmax,minmn); + +/* =================================================================== */ + +/* Quick return if possible for the case when the second or third */ +/* stopping criterion for the whole original matrix is satified, */ +/* i.e. MAXC2NRM <= ABSTOL or RELMAXC2NRM <= RELTOL */ +/* (which is ONE <= RELTOL). */ + + if (maxc2nrm <= *abstol || 1.f <= *reltol) { + + *k = 0; + *maxc2nrmk = maxc2nrm; + *relmaxc2nrmk = 1.f; + + i__1 = minmn; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + tau[i__2].r = 0.f, tau[i__2].i = 0.f; + } + + q__1.r = (real) lwkopt, q__1.i = 0.f; + work[1].r = q__1.r, work[1].i = q__1.i; + return 0; + } + +/* ================================================================== */ +/* Factorize columns */ +/* ================================================================== */ + +/* Determine the block size. */ + + nbmin = 2; + nx = 0; + + if (nb > 1 && nb < minmn) { + +/* Determine when to cross over from blocked to unblocked code. */ +/* (for N less than NX, unblocked code should be used). */ + +/* Computing MAX */ + i__1 = 0, i__2 = ilaenv_(&c__3, "CGEQP3RK", " ", m, n, &c_n1, &c_n1, ( + ftnlen)8, (ftnlen)1); + nx = f2cmax(i__1,i__2); + + if (nx < minmn) { + +/* Determine if workspace is large enough for blocked code. */ + + if (*lwork < lwkopt) { + +/* Not enough workspace to use optimal block size that */ +/* is currently stored in NB. */ +/* Reduce NB and determine the minimum value of NB. */ + + nb = (*lwork - (*n << 1)) / (*n + 1); +/* Computing MAX */ + i__1 = 2, i__2 = ilaenv_(&c__2, "CGEQP3RK", " ", m, n, &c_n1, + &c_n1, (ftnlen)8, (ftnlen)1); + nbmin = f2cmax(i__1,i__2); + + } + } + } + +/* ================================================================== */ + +/* DONE is the boolean flag to rerpresent the case when the */ +/* factorization completed in the block factorization routine, */ +/* before the end of the block. */ + + done = FALSE_; + +/* J is the column index. */ + + j = 1; + +/* (1) Use blocked code initially. */ + +/* JMAXB is the maximum column index of the block, when the */ +/* blocked code is used, is also limited by the first stopping */ +/* criterion KMAX. */ + +/* Computing MIN */ + i__1 = *kmax, i__2 = minmn - nx; + jmaxb = f2cmin(i__1,i__2); + + if (nb >= nbmin && nb < jmax && jmaxb > 0) { + +/* Loop over the column blocks of the matrix A(1:M,1:JMAXB). Here: */ +/* J is the column index of a column block; */ +/* JB is the column block size to pass to block factorization */ +/* routine in a loop step; */ +/* JBF is the number of columns that were actually factorized */ +/* that was returned by the block factorization routine */ +/* in a loop step, JBF <= JB; */ +/* N_SUB is the number of columns in the submatrix; */ +/* IOFFSET is the number of rows that should not be factorized. */ + + while(j <= jmaxb) { + +/* Computing MIN */ + i__1 = nb, i__2 = jmaxb - j + 1; + jb = f2cmin(i__1,i__2); + n_sub__ = *n - j + 1; + ioffset = j - 1; + +/* Factorize JB columns among the columns A(J:N). */ + + i__1 = *n + *nrhs - j + 1; + claqp3rk_(m, &n_sub__, nrhs, &ioffset, &jb, abstol, reltol, &kp1, + &maxc2nrm, &a[j * a_dim1 + 1], lda, &done, &jbf, + maxc2nrmk, relmaxc2nrmk, &jpiv[j], &tau[j], &rwork[j], & + rwork[*n + j], &work[1], &work[jb + 1], &i__1, &iwork[1], + &iinfo); + +/* Set INFO on the first occurence of Inf. */ + + if (iinfo > n_sub__ && *info == 0) { + *info = (ioffset << 1) + iinfo; + } + + if (done) { + +/* Either the submatrix is zero before the end of the */ +/* column block, or ABSTOL or RELTOL criterion is */ +/* satisfied before the end of the column block, we can */ +/* return from the routine. Perform the following before */ +/* returning: */ +/* a) Set the number of factorized columns K, */ +/* K = IOFFSET + JBF from the last call of blocked */ +/* routine. */ +/* NOTE: 1) MAXC2NRMK and RELMAXC2NRMK are returned */ +/* by the block factorization routine; */ +/* 2) The remaining TAUs are set to ZERO by the */ +/* block factorization routine. */ + + *k = ioffset + jbf; + +/* Set INFO on the first occurrence of NaN, NaN takes */ +/* prcedence over Inf. */ + + if (iinfo <= n_sub__ && iinfo > 0) { + *info = ioffset + iinfo; + } + +/* Return from the routine. */ + + q__1.r = (real) lwkopt, q__1.i = 0.f; + work[1].r = q__1.r, work[1].i = q__1.i; + + return 0; + + } + + j += jbf; + + } + + } + +/* Use unblocked code to factor the last or only block. */ +/* J = JMAX+1 means we factorized the maximum possible number of */ +/* columns, that is in ELSE clause we need to compute */ +/* the MAXC2NORM and RELMAXC2NORM to return after we processed */ +/* the blocks. */ + + if (j <= jmax) { + +/* N_SUB is the number of columns in the submatrix; */ +/* IOFFSET is the number of rows that should not be factorized. */ + + n_sub__ = *n - j + 1; + ioffset = j - 1; + + i__1 = jmax - j + 1; + claqp2rk_(m, &n_sub__, nrhs, &ioffset, &i__1, abstol, reltol, &kp1, & + maxc2nrm, &a[j * a_dim1 + 1], lda, &kf, maxc2nrmk, + relmaxc2nrmk, &jpiv[j], &tau[j], &rwork[j], &rwork[*n + j], & + work[1], &iinfo); + +/* ABSTOL or RELTOL criterion is satisfied when the number of */ +/* the factorized columns KF is smaller then the number */ +/* of columns JMAX-J+1 supplied to be factorized by the */ +/* unblocked routine, we can return from */ +/* the routine. Perform the following before returning: */ +/* a) Set the number of factorized columns K, */ +/* b) MAXC2NRMK and RELMAXC2NRMK are returned by the */ +/* unblocked factorization routine above. */ + + *k = j - 1 + kf; + +/* Set INFO on the first exception occurence. */ + +/* Set INFO on the first exception occurence of Inf or NaN, */ +/* (NaN takes precedence over Inf). */ + + if (iinfo > n_sub__ && *info == 0) { + *info = (ioffset << 1) + iinfo; + } else if (iinfo <= n_sub__ && iinfo > 0) { + *info = ioffset + iinfo; + } + + } else { + +/* Compute the return values for blocked code. */ + +/* Set the number of factorized columns if the unblocked routine */ +/* was not called. */ + + *k = jmax; + +/* If there exits a residual matrix after the blocked code: */ +/* 1) compute the values of MAXC2NRMK, RELMAXC2NRMK of the */ +/* residual matrix, otherwise set them to ZERO; */ +/* 2) Set TAU(K+1:MINMN) to ZERO. */ + + if (*k < minmn) { + i__1 = *n - *k; + jmaxc2nrm = *k + isamax_(&i__1, &rwork[*k + 1], &c__1); + *maxc2nrmk = rwork[jmaxc2nrm]; + if (*k == 0) { + *relmaxc2nrmk = 1.f; + } else { + *relmaxc2nrmk = *maxc2nrmk / maxc2nrm; + } + + i__1 = minmn; + for (j = *k + 1; j <= i__1; ++j) { + i__2 = j; + tau[i__2].r = 0.f, tau[i__2].i = 0.f; + } + + } else { + *maxc2nrmk = 0.f; + *relmaxc2nrmk = 0.f; + + } + +/* END IF( J.LE.JMAX ) THEN */ + + } + + q__1.r = (real) lwkopt, q__1.i = 0.f; + work[1].r = q__1.r, work[1].i = q__1.i; + + return 0; + +/* End of CGEQP3RK */ + +} /* cgeqp3rk_ */ + diff --git a/lapack-netlib/SRC/claqp2rk.c b/lapack-netlib/SRC/claqp2rk.c new file mode 100644 index 000000000..4184c5927 --- /dev/null +++ b/lapack-netlib/SRC/claqp2rk.c @@ -0,0 +1,943 @@ +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +#if defined(_WIN64) +typedef long long BLASLONG; +typedef unsigned long long BLASULONG; +#else +typedef long BLASLONG; +typedef unsigned long BLASULONG; +#endif + +#ifdef LAPACK_ILP64 +typedef BLASLONG blasint; +#if defined(_WIN64) +#define blasabs(x) llabs(x) +#else +#define blasabs(x) labs(x) +#endif +#else +typedef int blasint; +#define blasabs(x) abs(x) +#endif + +typedef blasint integer; + +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +#ifdef _MSC_VER +static inline _Fcomplex Cf(complex *z) {_Fcomplex zz={z->r , z->i}; return zz;} +static inline _Dcomplex Cd(doublecomplex *z) {_Dcomplex zz={z->r , z->i};return zz;} +static inline _Fcomplex * _pCf(complex *z) {return (_Fcomplex*)z;} +static inline _Dcomplex * _pCd(doublecomplex *z) {return (_Dcomplex*)z;} +#else +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#endif +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#ifdef _MSC_VER +#define c_div(c, a, b) {Cf(c)._Val[0] = (Cf(a)._Val[0]/Cf(b)._Val[0]); Cf(c)._Val[1]=(Cf(a)._Val[1]/Cf(b)._Val[1]);} +#define z_div(c, a, b) {Cd(c)._Val[0] = (Cd(a)._Val[0]/Cd(b)._Val[0]); Cd(c)._Val[1]=(Cd(a)._Val[1]/Cd(b)._Val[1]);} +#else +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#endif +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conjf(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimagf(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) {ceil(w)} +#define myhuge_(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +#ifdef _MSC_VER +static _Fcomplex cpow_ui(complex x, integer n) { + complex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x.r = 1/x.r, x.i=1/x.i; + for(u = n; ; ) { + if(u & 01) pow.r *= x.r, pow.i *= x.i; + if(u >>= 1) x.r *= x.r, x.i *= x.i; + else break; + } + } + _Fcomplex p={pow.r, pow.i}; + return p; +} +#else +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +#endif +#ifdef _MSC_VER +static _Dcomplex zpow_ui(_Dcomplex x, integer n) { + _Dcomplex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x._Val[0] = 1/x._Val[0], x._Val[1] =1/x._Val[1]; + for(u = n; ; ) { + if(u & 01) pow._Val[0] *= x._Val[0], pow._Val[1] *= x._Val[1]; + if(u >>= 1) x._Val[0] *= x._Val[0], x._Val[1] *= x._Val[1]; + else break; + } + } + _Dcomplex p = {pow._Val[0], pow._Val[1]}; + return p; +} +#else +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +#endif +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; +#ifdef _MSC_VER + _Fcomplex zdotc = {0.0, 0.0}; + if (incx == 1 && incy == 1) { + for (i=0;i myhugeval) { + *info = *n + kk - 1 + kp; + } + +/* ============================================================ */ + +/* Test for the second and third stopping criteria. */ +/* NOTE: There is no need to test for ABSTOL >= ZERO, since */ +/* MAXC2NRMK is non-negative. Similarly, there is no need */ +/* to test for RELTOL >= ZERO, since RELMAXC2NRMK is */ +/* non-negative. */ +/* We need to check the condition only if the */ +/* column index (same as row index) of the original whole */ +/* matrix is larger than 1, since the condition for whole */ +/* original matrix is checked in the main routine. */ + *relmaxc2nrmk = *maxc2nrmk / *maxc2nrm; + + if (*maxc2nrmk <= *abstol || *relmaxc2nrmk <= *reltol) { + +/* Set K, the number of factorized columns. */ + + *k = kk - 1; + +/* Set TAUs corresponding to the columns that were not */ +/* factorized to ZERO, i.e. set TAU(KK:MINMNFACT) to CZERO. */ + + i__2 = minmnfact; + for (j = kk; j <= i__2; ++j) { + i__3 = j; + tau[i__3].r = 0.f, tau[i__3].i = 0.f; + } + +/* Return from the routine. */ + + return 0; + + } + +/* ============================================================ */ + +/* End ELSE of IF(I.EQ.1) */ + + } + +/* =============================================================== */ + +/* If the pivot column is not the first column of the */ +/* subblock A(1:M,KK:N): */ +/* 1) swap the KK-th column and the KP-th pivot column */ +/* in A(1:M,1:N); */ +/* 2) copy the KK-th element into the KP-th element of the partial */ +/* and exact 2-norm vectors VN1 and VN2. ( Swap is not needed */ +/* for VN1 and VN2 since we use the element with the index */ +/* larger than KK in the next loop step.) */ +/* 3) Save the pivot interchange with the indices relative to the */ +/* the original matrix A, not the block A(1:M,1:N). */ + + if (kp != kk) { + cswap_(m, &a[kp * a_dim1 + 1], &c__1, &a[kk * a_dim1 + 1], &c__1); + vn1[kp] = vn1[kk]; + vn2[kp] = vn2[kk]; + itemp = jpiv[kp]; + jpiv[kp] = jpiv[kk]; + jpiv[kk] = itemp; + } + +/* Generate elementary reflector H(KK) using the column A(I:M,KK), */ +/* if the column has more than one element, otherwise */ +/* the elementary reflector would be an identity matrix, */ +/* and TAU(KK) = CZERO. */ + + if (i__ < *m) { + i__2 = *m - i__ + 1; + clarfg_(&i__2, &a[i__ + kk * a_dim1], &a[i__ + 1 + kk * a_dim1], & + c__1, &tau[kk]); + } else { + i__2 = kk; + tau[i__2].r = 0.f, tau[i__2].i = 0.f; + } + +/* Check if TAU(KK) contains NaN, set INFO parameter */ +/* to the column number where NaN is found and return from */ +/* the routine. */ +/* NOTE: There is no need to check TAU(KK) for Inf, */ +/* since CLARFG cannot produce TAU(KK) or Householder vector */ +/* below the diagonal containing Inf. Only BETA on the diagonal, */ +/* returned by CLARFG can contain Inf, which requires */ +/* TAU(KK) to contain NaN. Therefore, this case of generating Inf */ +/* by CLARFG is covered by checking TAU(KK) for NaN. */ + + i__2 = kk; + r__1 = tau[i__2].r; + if (sisnan_(&r__1)) { + i__2 = kk; + taunan = tau[i__2].r; + } else /* if(complicated condition) */ { + r__1 = r_imag(&tau[kk]); + if (sisnan_(&r__1)) { + taunan = r_imag(&tau[kk]); + } else { + taunan = 0.f; + } + } + + if (sisnan_(&taunan)) { + *k = kk - 1; + *info = kk; + +/* Set MAXC2NRMK and RELMAXC2NRMK to NaN. */ + + *maxc2nrmk = taunan; + *relmaxc2nrmk = taunan; + +/* Array TAU(KK:MINMNFACT) is not set and contains */ +/* undefined elements, except the first element TAU(KK) = NaN. */ + + return 0; + } + +/* Apply H(KK)**H to A(I:M,KK+1:N+NRHS) from the left. */ +/* ( If M >= N, then at KK = N there is no residual matrix, */ +/* i.e. no columns of A to update, only columns of B. */ +/* If M < N, then at KK = M-IOFFSET, I = M and we have a */ +/* one-row residual matrix in A and the elementary */ +/* reflector is a unit matrix, TAU(KK) = CZERO, i.e. no update */ +/* is needed for the residual matrix in A and the */ +/* right-hand-side-matrix in B. */ +/* Therefore, we update only if */ +/* KK < MINMNUPDT = f2cmin(M-IOFFSET, N+NRHS) */ +/* condition is satisfied, not only KK < N+NRHS ) */ + + if (kk < minmnupdt) { + i__2 = i__ + kk * a_dim1; + aikk.r = a[i__2].r, aikk.i = a[i__2].i; + i__2 = i__ + kk * a_dim1; + a[i__2].r = 1.f, a[i__2].i = 0.f; + i__2 = *m - i__ + 1; + i__3 = *n + *nrhs - kk; + r_cnjg(&q__1, &tau[kk]); + clarf_("Left", &i__2, &i__3, &a[i__ + kk * a_dim1], &c__1, &q__1, + &a[i__ + (kk + 1) * a_dim1], lda, &work[1]); + i__2 = i__ + kk * a_dim1; + a[i__2].r = aikk.r, a[i__2].i = aikk.i; + } + + if (kk < minmnfact) { + +/* Update the partial column 2-norms for the residual matrix, */ +/* only if the residual matrix A(I+1:M,KK+1:N) exists, i.e. */ +/* when KK < f2cmin(M-IOFFSET, N). */ + + i__2 = *n; + for (j = kk + 1; j <= i__2; ++j) { + if (vn1[j] != 0.f) { + +/* NOTE: The following lines follow from the analysis in */ +/* Lapack Working Note 176. */ + +/* Computing 2nd power */ + r__1 = c_abs(&a[i__ + j * a_dim1]) / vn1[j]; + temp = 1.f - r__1 * r__1; + temp = f2cmax(temp,0.f); +/* Computing 2nd power */ + r__1 = vn1[j] / vn2[j]; + temp2 = temp * (r__1 * r__1); + if (temp2 <= tol3z) { + +/* Compute the column 2-norm for the partial */ +/* column A(I+1:M,J) by explicitly computing it, */ +/* and store it in both partial 2-norm vector VN1 */ +/* and exact column 2-norm vector VN2. */ + + i__3 = *m - i__; + vn1[j] = scnrm2_(&i__3, &a[i__ + 1 + j * a_dim1], & + c__1); + vn2[j] = vn1[j]; + + } else { + +/* Update the column 2-norm for the partial */ +/* column A(I+1:M,J) by removing one */ +/* element A(I,J) and store it in partial */ +/* 2-norm vector VN1. */ + + vn1[j] *= sqrt(temp); + + } + } + } + + } + +/* End factorization loop */ + + } + +/* If we reached this point, all colunms have been factorized, */ +/* i.e. no condition was triggered to exit the routine. */ +/* Set the number of factorized columns. */ + + *k = *kmax; + +/* We reached the end of the loop, i.e. all KMAX columns were */ +/* factorized, we need to set MAXC2NRMK and RELMAXC2NRMK before */ +/* we return. */ + + if (*k < minmnfact) { + + i__1 = *n - *k; + jmaxc2nrm = *k + isamax_(&i__1, &vn1[*k + 1], &c__1); + *maxc2nrmk = vn1[jmaxc2nrm]; + + if (*k == 0) { + *relmaxc2nrmk = 1.f; + } else { + *relmaxc2nrmk = *maxc2nrmk / *maxc2nrm; + } + + } else { + *maxc2nrmk = 0.f; + *relmaxc2nrmk = 0.f; + } + +/* We reached the end of the loop, i.e. all KMAX columns were */ +/* factorized, set TAUs corresponding to the columns that were */ +/* not factorized to ZERO, i.e. TAU(K+1:MINMNFACT) set to CZERO. */ + + i__1 = minmnfact; + for (j = *k + 1; j <= i__1; ++j) { + i__2 = j; + tau[i__2].r = 0.f, tau[i__2].i = 0.f; + } + + return 0; + +/* End of CLAQP2RK */ + +} /* claqp2rk_ */ + diff --git a/lapack-netlib/SRC/claqp3rk.c b/lapack-netlib/SRC/claqp3rk.c new file mode 100644 index 000000000..ca305fab7 --- /dev/null +++ b/lapack-netlib/SRC/claqp3rk.c @@ -0,0 +1,1152 @@ +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +#if defined(_WIN64) +typedef long long BLASLONG; +typedef unsigned long long BLASULONG; +#else +typedef long BLASLONG; +typedef unsigned long BLASULONG; +#endif + +#ifdef LAPACK_ILP64 +typedef BLASLONG blasint; +#if defined(_WIN64) +#define blasabs(x) llabs(x) +#else +#define blasabs(x) labs(x) +#endif +#else +typedef int blasint; +#define blasabs(x) abs(x) +#endif + +typedef blasint integer; + +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +#ifdef _MSC_VER +static inline _Fcomplex Cf(complex *z) {_Fcomplex zz={z->r , z->i}; return zz;} +static inline _Dcomplex Cd(doublecomplex *z) {_Dcomplex zz={z->r , z->i};return zz;} +static inline _Fcomplex * _pCf(complex *z) {return (_Fcomplex*)z;} +static inline _Dcomplex * _pCd(doublecomplex *z) {return (_Dcomplex*)z;} +#else +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#endif +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#ifdef _MSC_VER +#define c_div(c, a, b) {Cf(c)._Val[0] = (Cf(a)._Val[0]/Cf(b)._Val[0]); Cf(c)._Val[1]=(Cf(a)._Val[1]/Cf(b)._Val[1]);} +#define z_div(c, a, b) {Cd(c)._Val[0] = (Cd(a)._Val[0]/Cd(b)._Val[0]); Cd(c)._Val[1]=(Cd(a)._Val[1]/Cd(b)._Val[1]);} +#else +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#endif +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conjf(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimagf(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) {ceil(w)} +#define myhuge_(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +#ifdef _MSC_VER +static _Fcomplex cpow_ui(complex x, integer n) { + complex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x.r = 1/x.r, x.i=1/x.i; + for(u = n; ; ) { + if(u & 01) pow.r *= x.r, pow.i *= x.i; + if(u >>= 1) x.r *= x.r, x.i *= x.i; + else break; + } + } + _Fcomplex p={pow.r, pow.i}; + return p; +} +#else +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +#endif +#ifdef _MSC_VER +static _Dcomplex zpow_ui(_Dcomplex x, integer n) { + _Dcomplex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x._Val[0] = 1/x._Val[0], x._Val[1] =1/x._Val[1]; + for(u = n; ; ) { + if(u & 01) pow._Val[0] *= x._Val[0], pow._Val[1] *= x._Val[1]; + if(u >>= 1) x._Val[0] *= x._Val[0], x._Val[1] *= x._Val[1]; + else break; + } + } + _Dcomplex p = {pow._Val[0], pow._Val[1]}; + return p; +} +#else +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +#endif +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; +#ifdef _MSC_VER + _Fcomplex zdotc = {0.0, 0.0}; + if (incx == 1 && incy == 1) { + for (i=0;i 0 && *kb < *m - *ioffset) { + i__1 = *m - if__; + q__1.r = -1.f, q__1.i = 0.f; + cgemm_("No transpose", "Conjugate transpose", &i__1, nrhs, + kb, &q__1, &a[if__ + 1 + a_dim1], lda, &f[*n + 1 + + f_dim1], ldf, &c_b2, &a[if__ + 1 + (*n + 1) * + a_dim1], lda); + } + +/* There is no need to recompute the 2-norm of the */ +/* difficult columns, since we stop the factorization. */ + +/* Array TAU(KF+1:MINMNFACT) is not set and contains */ +/* undefined elements. */ + +/* Return from the routine. */ + + return 0; + } + +/* Quick return, if the submatrix A(I:M,K:N) is */ +/* a zero matrix. We need to check it only if the column index */ +/* (same as row index) is larger than 1, since the condition */ +/* for the whole original matrix A_orig is checked in the main */ +/* routine. */ + + if (*maxc2nrmk == 0.f) { + + *done = TRUE_; + +/* Set KB, the number of factorized partial columns */ +/* that are non-zero in each step in the block, */ +/* i.e. the rank of the factor R. */ +/* Set IF, the number of processed rows in the block, which */ +/* is the same as the number of processed rows in */ +/* the original whole matrix A_orig. */ + + *kb = k - 1; + if__ = i__ - 1; + *relmaxc2nrmk = 0.f; + +/* There is no need to apply the block reflector to the */ +/* residual of the matrix A stored in A(KB+1:M,KB+1:N), */ +/* since the submatrix is zero and we stop the computation. */ +/* But, we need to apply the block reflector to the residual */ +/* right hand sides stored in A(KB+1:M,N+1:N+NRHS), if the */ +/* residual right hand sides exist. This occurs */ +/* when ( NRHS != 0 AND KB <= (M-IOFFSET) ): */ + +/* A(I+1:M,N+1:N+NRHS) := A(I+1:M,N+1:N+NRHS) - */ +/* A(I+1:M,1:KB) * F(N+1:N+NRHS,1:KB)**H. */ + + if (*nrhs > 0 && *kb < *m - *ioffset) { + i__1 = *m - if__; + q__1.r = -1.f, q__1.i = 0.f; + cgemm_("No transpose", "Conjugate transpose", &i__1, nrhs, + kb, &q__1, &a[if__ + 1 + a_dim1], lda, &f[*n + 1 + + f_dim1], ldf, &c_b2, &a[if__ + 1 + (*n + 1) * + a_dim1], lda); + } + +/* There is no need to recompute the 2-norm of the */ +/* difficult columns, since we stop the factorization. */ + +/* Set TAUs corresponding to the columns that were not */ +/* factorized to ZERO, i.e. set TAU(KB+1:MINMNFACT) = CZERO, */ +/* which is equivalent to seting TAU(K:MINMNFACT) = CZERO. */ + + i__1 = minmnfact; + for (j = k; j <= i__1; ++j) { + i__2 = j; + tau[i__2].r = 0.f, tau[i__2].i = 0.f; + } + +/* Return from the routine. */ + + return 0; + + } + +/* ============================================================ */ + +/* Check if the submatrix A(I:M,K:N) contains Inf, */ +/* set INFO parameter to the column number, where */ +/* the first Inf is found plus N, and continue */ +/* the computation. */ +/* We need to check the condition only if the */ +/* column index (same as row index) of the original whole */ +/* matrix is larger than 1, since the condition for whole */ +/* original matrix is checked in the main routine. */ + + if (*info == 0 && *maxc2nrmk > myhugeval) { + *info = *n + k - 1 + kp; + } + +/* ============================================================ */ + +/* Test for the second and third tolerance stopping criteria. */ +/* NOTE: There is no need to test for ABSTOL.GE.ZERO, since */ +/* MAXC2NRMK is non-negative. Similarly, there is no need */ +/* to test for RELTOL.GE.ZERO, since RELMAXC2NRMK is */ +/* non-negative. */ +/* We need to check the condition only if the */ +/* column index (same as row index) of the original whole */ +/* matrix is larger than 1, since the condition for whole */ +/* original matrix is checked in the main routine. */ + + *relmaxc2nrmk = *maxc2nrmk / *maxc2nrm; + + if (*maxc2nrmk <= *abstol || *relmaxc2nrmk <= *reltol) { + + *done = TRUE_; + +/* Set KB, the number of factorized partial columns */ +/* that are non-zero in each step in the block, */ +/* i.e. the rank of the factor R. */ +/* Set IF, the number of processed rows in the block, which */ +/* is the same as the number of processed rows in */ +/* the original whole matrix A_orig; */ + + *kb = k - 1; + if__ = i__ - 1; + +/* Apply the block reflector to the residual of the */ +/* matrix A and the residual of the right hand sides B, if */ +/* the residual matrix and and/or the residual of the right */ +/* hand sides exist, i.e. if the submatrix */ +/* A(I+1:M,KB+1:N+NRHS) exists. This occurs when */ +/* KB < MINMNUPDT = f2cmin( M-IOFFSET, N+NRHS ): */ + +/* A(IF+1:M,K+1:N+NRHS) := A(IF+1:M,KB+1:N+NRHS) - */ +/* A(IF+1:M,1:KB) * F(KB+1:N+NRHS,1:KB)**H. */ + + if (*kb < minmnupdt) { + i__1 = *m - if__; + i__2 = *n + *nrhs - *kb; + q__1.r = -1.f, q__1.i = 0.f; + cgemm_("No transpose", "Conjugate transpose", &i__1, & + i__2, kb, &q__1, &a[if__ + 1 + a_dim1], lda, &f[* + kb + 1 + f_dim1], ldf, &c_b2, &a[if__ + 1 + (*kb + + 1) * a_dim1], lda); + } + +/* There is no need to recompute the 2-norm of the */ +/* difficult columns, since we stop the factorization. */ + +/* Set TAUs corresponding to the columns that were not */ +/* factorized to ZERO, i.e. set TAU(KB+1:MINMNFACT) = CZERO, */ +/* which is equivalent to seting TAU(K:MINMNFACT) = CZERO. */ + + i__1 = minmnfact; + for (j = k; j <= i__1; ++j) { + i__2 = j; + tau[i__2].r = 0.f, tau[i__2].i = 0.f; + } + +/* Return from the routine. */ + + return 0; + + } + +/* ============================================================ */ + +/* End ELSE of IF(I.EQ.1) */ + + } + +/* =============================================================== */ + +/* If the pivot column is not the first column of the */ +/* subblock A(1:M,K:N): */ +/* 1) swap the K-th column and the KP-th pivot column */ +/* in A(1:M,1:N); */ +/* 2) swap the K-th row and the KP-th row in F(1:N,1:K-1) */ +/* 3) copy the K-th element into the KP-th element of the partial */ +/* and exact 2-norm vectors VN1 and VN2. (Swap is not needed */ +/* for VN1 and VN2 since we use the element with the index */ +/* larger than K in the next loop step.) */ +/* 4) Save the pivot interchange with the indices relative to the */ +/* the original matrix A_orig, not the block A(1:M,1:N). */ + + if (kp != k) { + cswap_(m, &a[kp * a_dim1 + 1], &c__1, &a[k * a_dim1 + 1], &c__1); + i__1 = k - 1; + cswap_(&i__1, &f[kp + f_dim1], ldf, &f[k + f_dim1], ldf); + vn1[kp] = vn1[k]; + vn2[kp] = vn2[k]; + itemp = jpiv[kp]; + jpiv[kp] = jpiv[k]; + jpiv[k] = itemp; + } + +/* Apply previous Householder reflectors to column K: */ +/* A(I:M,K) := A(I:M,K) - A(I:M,1:K-1)*F(K,1:K-1)**H. */ + + if (k > 1) { + i__1 = k - 1; + for (j = 1; j <= i__1; ++j) { + i__2 = k + j * f_dim1; + r_cnjg(&q__1, &f[k + j * f_dim1]); + f[i__2].r = q__1.r, f[i__2].i = q__1.i; + } + i__1 = *m - i__ + 1; + i__2 = k - 1; + q__1.r = -1.f, q__1.i = 0.f; + cgemv_("No transpose", &i__1, &i__2, &q__1, &a[i__ + a_dim1], lda, + &f[k + f_dim1], ldf, &c_b2, &a[i__ + k * a_dim1], &c__1); + i__1 = k - 1; + for (j = 1; j <= i__1; ++j) { + i__2 = k + j * f_dim1; + r_cnjg(&q__1, &f[k + j * f_dim1]); + f[i__2].r = q__1.r, f[i__2].i = q__1.i; + } + } + +/* Generate elementary reflector H(k) using the column A(I:M,K). */ + + if (i__ < *m) { + i__1 = *m - i__ + 1; + clarfg_(&i__1, &a[i__ + k * a_dim1], &a[i__ + 1 + k * a_dim1], & + c__1, &tau[k]); + } else { + i__1 = k; + tau[i__1].r = 0.f, tau[i__1].i = 0.f; + } + +/* Check if TAU(K) contains NaN, set INFO parameter */ +/* to the column number where NaN is found and return from */ +/* the routine. */ +/* NOTE: There is no need to check TAU(K) for Inf, */ +/* since CLARFG cannot produce TAU(KK) or Householder vector */ +/* below the diagonal containing Inf. Only BETA on the diagonal, */ +/* returned by CLARFG can contain Inf, which requires */ +/* TAU(K) to contain NaN. Therefore, this case of generating Inf */ +/* by CLARFG is covered by checking TAU(K) for NaN. */ + + i__1 = k; + r__1 = tau[i__1].r; + if (sisnan_(&r__1)) { + i__1 = k; + taunan = tau[i__1].r; + } else /* if(complicated condition) */ { + r__1 = r_imag(&tau[k]); + if (sisnan_(&r__1)) { + taunan = r_imag(&tau[k]); + } else { + taunan = 0.f; + } + } + + if (sisnan_(&taunan)) { + + *done = TRUE_; + +/* Set KB, the number of factorized partial columns */ +/* that are non-zero in each step in the block, */ +/* i.e. the rank of the factor R. */ +/* Set IF, the number of processed rows in the block, which */ +/* is the same as the number of processed rows in */ +/* the original whole matrix A_orig. */ + + *kb = k - 1; + if__ = i__ - 1; + *info = k; + +/* Set MAXC2NRMK and RELMAXC2NRMK to NaN. */ + + *maxc2nrmk = taunan; + *relmaxc2nrmk = taunan; + +/* There is no need to apply the block reflector to the */ +/* residual of the matrix A stored in A(KB+1:M,KB+1:N), */ +/* since the submatrix contains NaN and we stop */ +/* the computation. */ +/* But, we need to apply the block reflector to the residual */ +/* right hand sides stored in A(KB+1:M,N+1:N+NRHS), if the */ +/* residual right hand sides exist. This occurs */ +/* when ( NRHS != 0 AND KB <= (M-IOFFSET) ): */ + +/* A(I+1:M,N+1:N+NRHS) := A(I+1:M,N+1:N+NRHS) - */ +/* A(I+1:M,1:KB) * F(N+1:N+NRHS,1:KB)**H. */ + + if (*nrhs > 0 && *kb < *m - *ioffset) { + i__1 = *m - if__; + q__1.r = -1.f, q__1.i = 0.f; + cgemm_("No transpose", "Conjugate transpose", &i__1, nrhs, kb, + &q__1, &a[if__ + 1 + a_dim1], lda, &f[*n + 1 + + f_dim1], ldf, &c_b2, &a[if__ + 1 + (*n + 1) * a_dim1], + lda); + } + +/* There is no need to recompute the 2-norm of the */ +/* difficult columns, since we stop the factorization. */ + +/* Array TAU(KF+1:MINMNFACT) is not set and contains */ +/* undefined elements. */ + +/* Return from the routine. */ + + return 0; + } + +/* =============================================================== */ + + i__1 = i__ + k * a_dim1; + aik.r = a[i__1].r, aik.i = a[i__1].i; + i__1 = i__ + k * a_dim1; + a[i__1].r = 1.f, a[i__1].i = 0.f; + +/* =============================================================== */ + +/* Compute the current K-th column of F: */ +/* 1) F(K+1:N,K) := tau(K) * A(I:M,K+1:N)**H * A(I:M,K). */ + + if (k < *n + *nrhs) { + i__1 = *m - i__ + 1; + i__2 = *n + *nrhs - k; + cgemv_("Conjugate transpose", &i__1, &i__2, &tau[k], &a[i__ + (k + + 1) * a_dim1], lda, &a[i__ + k * a_dim1], &c__1, &c_b1, & + f[k + 1 + k * f_dim1], &c__1); + } + +/* 2) Zero out elements above and on the diagonal of the */ +/* column K in matrix F, i.e elements F(1:K,K). */ + + i__1 = k; + for (j = 1; j <= i__1; ++j) { + i__2 = j + k * f_dim1; + f[i__2].r = 0.f, f[i__2].i = 0.f; + } + +/* 3) Incremental updating of the K-th column of F: */ +/* F(1:N,K) := F(1:N,K) - tau(K) * F(1:N,1:K-1) * A(I:M,1:K-1)**H */ +/* * A(I:M,K). */ + + if (k > 1) { + i__1 = *m - i__ + 1; + i__2 = k - 1; + i__3 = k; + q__1.r = -tau[i__3].r, q__1.i = -tau[i__3].i; + cgemv_("Conjugate Transpose", &i__1, &i__2, &q__1, &a[i__ + + a_dim1], lda, &a[i__ + k * a_dim1], &c__1, &c_b1, &auxv[1] + , &c__1); + + i__1 = *n + *nrhs; + i__2 = k - 1; + cgemv_("No transpose", &i__1, &i__2, &c_b2, &f[f_dim1 + 1], ldf, & + auxv[1], &c__1, &c_b2, &f[k * f_dim1 + 1], &c__1); + } + +/* =============================================================== */ + +/* Update the current I-th row of A: */ +/* A(I,K+1:N+NRHS) := A(I,K+1:N+NRHS) */ +/* - A(I,1:K)*F(K+1:N+NRHS,1:K)**H. */ + + if (k < *n + *nrhs) { + i__1 = *n + *nrhs - k; + q__1.r = -1.f, q__1.i = 0.f; + cgemm_("No transpose", "Conjugate transpose", &c__1, &i__1, &k, & + q__1, &a[i__ + a_dim1], lda, &f[k + 1 + f_dim1], ldf, & + c_b2, &a[i__ + (k + 1) * a_dim1], lda); + } + + i__1 = i__ + k * a_dim1; + a[i__1].r = aik.r, a[i__1].i = aik.i; + +/* Update the partial column 2-norms for the residual matrix, */ +/* only if the residual matrix A(I+1:M,K+1:N) exists, i.e. */ +/* when K < MINMNFACT = f2cmin( M-IOFFSET, N ). */ + + if (k < minmnfact) { + + i__1 = *n; + for (j = k + 1; j <= i__1; ++j) { + if (vn1[j] != 0.f) { + +/* NOTE: The following lines follow from the analysis in */ +/* Lapack Working Note 176. */ + + temp = c_abs(&a[i__ + j * a_dim1]) / vn1[j]; +/* Computing MAX */ + r__1 = 0.f, r__2 = (temp + 1.f) * (1.f - temp); + temp = f2cmax(r__1,r__2); +/* Computing 2nd power */ + r__1 = vn1[j] / vn2[j]; + temp2 = temp * (r__1 * r__1); + if (temp2 <= tol3z) { + +/* At J-index, we have a difficult column for the */ +/* update of the 2-norm. Save the index of the previous */ +/* difficult column in IWORK(J-1). */ +/* NOTE: ILSTCC > 1, threfore we can use IWORK only */ +/* with N-1 elements, where the elements are */ +/* shifted by 1 to the left. */ + + iwork[j - 1] = lsticc; + +/* Set the index of the last difficult column LSTICC. */ + + lsticc = j; + + } else { + vn1[j] *= sqrt(temp); + } + } + } + + } + +/* End of while loop. */ + + } + +/* Now, afler the loop: */ +/* Set KB, the number of factorized columns in the block; */ +/* Set IF, the number of processed rows in the block, which */ +/* is the same as the number of processed rows in */ +/* the original whole matrix A_orig, IF = IOFFSET + KB. */ + + *kb = k; + if__ = i__; + +/* Apply the block reflector to the residual of the matrix A */ +/* and the residual of the right hand sides B, if the residual */ +/* matrix and and/or the residual of the right hand sides */ +/* exist, i.e. if the submatrix A(I+1:M,KB+1:N+NRHS) exists. */ +/* This occurs when KB < MINMNUPDT = f2cmin( M-IOFFSET, N+NRHS ): */ + +/* A(IF+1:M,K+1:N+NRHS) := A(IF+1:M,KB+1:N+NRHS) - */ +/* A(IF+1:M,1:KB) * F(KB+1:N+NRHS,1:KB)**H. */ + + if (*kb < minmnupdt) { + i__1 = *m - if__; + i__2 = *n + *nrhs - *kb; + q__1.r = -1.f, q__1.i = 0.f; + cgemm_("No transpose", "Conjugate transpose", &i__1, &i__2, kb, &q__1, + &a[if__ + 1 + a_dim1], lda, &f[*kb + 1 + f_dim1], ldf, &c_b2, + &a[if__ + 1 + (*kb + 1) * a_dim1], lda); + } + +/* Recompute the 2-norm of the difficult columns. */ +/* Loop over the index of the difficult columns from the largest */ +/* to the smallest index. */ + + while(lsticc > 0) { + +/* LSTICC is the index of the last difficult column is greater */ +/* than 1. */ +/* ITEMP is the index of the previous difficult column. */ + + itemp = iwork[lsticc - 1]; + +/* Compute the 2-norm explicilty for the last difficult column and */ +/* save it in the partial and exact 2-norm vectors VN1 and VN2. */ + +/* NOTE: The computation of VN1( LSTICC ) relies on the fact that */ +/* SCNRM2 does not fail on vectors with norm below the value of */ +/* SQRT(SLAMCH('S')) */ + + i__1 = *m - if__; + vn1[lsticc] = scnrm2_(&i__1, &a[if__ + 1 + lsticc * a_dim1], &c__1); + vn2[lsticc] = vn1[lsticc]; + +/* Downdate the index of the last difficult column to */ +/* the index of the previous difficult column. */ + + lsticc = itemp; + + } + + return 0; + +/* End of CLAQP3RK */ + +} /* claqp3rk_ */ + diff --git a/lapack-netlib/SRC/dgeqp3rk.c b/lapack-netlib/SRC/dgeqp3rk.c new file mode 100644 index 000000000..17a78dd5a --- /dev/null +++ b/lapack-netlib/SRC/dgeqp3rk.c @@ -0,0 +1,1059 @@ +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +#if defined(_WIN64) +typedef long long BLASLONG; +typedef unsigned long long BLASULONG; +#else +typedef long BLASLONG; +typedef unsigned long BLASULONG; +#endif + +#ifdef LAPACK_ILP64 +typedef BLASLONG blasint; +#if defined(_WIN64) +#define blasabs(x) llabs(x) +#else +#define blasabs(x) labs(x) +#endif +#else +typedef int blasint; +#define blasabs(x) abs(x) +#endif + +typedef blasint integer; + +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +#ifdef _MSC_VER +static inline _Fcomplex Cf(complex *z) {_Fcomplex zz={z->r , z->i}; return zz;} +static inline _Dcomplex Cd(doublecomplex *z) {_Dcomplex zz={z->r , z->i};return zz;} +static inline _Fcomplex * _pCf(complex *z) {return (_Fcomplex*)z;} +static inline _Dcomplex * _pCd(doublecomplex *z) {return (_Dcomplex*)z;} +#else +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#endif +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#ifdef _MSC_VER +#define c_div(c, a, b) {Cf(c)._Val[0] = (Cf(a)._Val[0]/Cf(b)._Val[0]); Cf(c)._Val[1]=(Cf(a)._Val[1]/Cf(b)._Val[1]);} +#define z_div(c, a, b) {Cd(c)._Val[0] = (Cd(a)._Val[0]/Cd(b)._Val[0]); Cd(c)._Val[1]=(Cd(a)._Val[1]/Cd(b)._Val[1]);} +#else +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#endif +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conjf(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimagf(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) {ceil(w)} +#define myhuge_(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +#ifdef _MSC_VER +static _Fcomplex cpow_ui(complex x, integer n) { + complex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x.r = 1/x.r, x.i=1/x.i; + for(u = n; ; ) { + if(u & 01) pow.r *= x.r, pow.i *= x.i; + if(u >>= 1) x.r *= x.r, x.i *= x.i; + else break; + } + } + _Fcomplex p={pow.r, pow.i}; + return p; +} +#else +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +#endif +#ifdef _MSC_VER +static _Dcomplex zpow_ui(_Dcomplex x, integer n) { + _Dcomplex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x._Val[0] = 1/x._Val[0], x._Val[1] =1/x._Val[1]; + for(u = n; ; ) { + if(u & 01) pow._Val[0] *= x._Val[0], pow._Val[1] *= x._Val[1]; + if(u >>= 1) x._Val[0] *= x._Val[0], x._Val[1] *= x._Val[1]; + else break; + } + } + _Dcomplex p = {pow._Val[0], pow._Val[1]}; + return p; +} +#else +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +#endif +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; +#ifdef _MSC_VER + _Fcomplex zdotc = {0.0, 0.0}; + if (incx == 1 && incy == 1) { + for (i=0;i myhugeval) { + +/* Check if the matrix A contains +Inf or -Inf, set INFO parameter */ +/* to the column number, where the first +/-Inf is found plus N, */ +/* and continue the computation. */ + + *info = *n + kp1; + + } + +/* ================================================================== */ + +/* Quick return if possible for the case when the first */ +/* stopping criterion is satisfied, i.e. KMAX = 0. */ + + if (*kmax == 0) { + *k = 0; + *maxc2nrmk = maxc2nrm; + *relmaxc2nrmk = 1.; + i__1 = minmn; + for (j = 1; j <= i__1; ++j) { + tau[j] = 0.; + } + work[1] = (doublereal) lwkopt; + return 0; + } + +/* ================================================================== */ + + eps = dlamch_("Epsilon"); + +/* Adjust ABSTOL */ + + if (*abstol >= 0.) { + safmin = dlamch_("Safe minimum"); +/* Computing MAX */ + d__1 = *abstol, d__2 = safmin * 2.; + *abstol = f2cmax(d__1,d__2); + } + +/* Adjust RELTOL */ + + if (*reltol >= 0.) { + *reltol = f2cmax(*reltol,eps); + } + +/* =================================================================== */ + +/* JMAX is the maximum index of the column to be factorized, */ +/* which is also limited by the first stopping criterion KMAX. */ + + jmax = f2cmin(*kmax,minmn); + +/* =================================================================== */ + +/* Quick return if possible for the case when the second or third */ +/* stopping criterion for the whole original matrix is satified, */ +/* i.e. MAXC2NRM <= ABSTOL or RELMAXC2NRM <= RELTOL */ +/* (which is ONE <= RELTOL). */ + + if (maxc2nrm <= *abstol || 1. <= *reltol) { + + *k = 0; + *maxc2nrmk = maxc2nrm; + *relmaxc2nrmk = 1.; + + i__1 = minmn; + for (j = 1; j <= i__1; ++j) { + tau[j] = 0.; + } + + work[1] = (doublereal) lwkopt; + return 0; + } + +/* ================================================================== */ +/* Factorize columns */ +/* ================================================================== */ + +/* Determine the block size. */ + + nbmin = 2; + nx = 0; + + if (nb > 1 && nb < minmn) { + +/* Determine when to cross over from blocked to unblocked code. */ +/* (for N less than NX, unblocked code should be used). */ + +/* Computing MAX */ + i__1 = 0, i__2 = ilaenv_(&c__3, "DGEQP3RK", " ", m, n, &c_n1, &c_n1, ( + ftnlen)8, (ftnlen)1); + nx = f2cmax(i__1,i__2); + + if (nx < minmn) { + +/* Determine if workspace is large enough for blocked code. */ + + if (*lwork < lwkopt) { + +/* Not enough workspace to use optimal block size that */ +/* is currently stored in NB. */ +/* Reduce NB and determine the minimum value of NB. */ + + nb = (*lwork - (*n << 1)) / (*n + 1); +/* Computing MAX */ + i__1 = 2, i__2 = ilaenv_(&c__2, "DGEQP3RK", " ", m, n, &c_n1, + &c_n1, (ftnlen)8, (ftnlen)1); + nbmin = f2cmax(i__1,i__2); + + } + } + } + +/* ================================================================== */ + +/* DONE is the boolean flag to rerpresent the case when the */ +/* factorization completed in the block factorization routine, */ +/* before the end of the block. */ + + done = FALSE_; + +/* J is the column index. */ + + j = 1; + +/* (1) Use blocked code initially. */ + +/* JMAXB is the maximum column index of the block, when the */ +/* blocked code is used, is also limited by the first stopping */ +/* criterion KMAX. */ + +/* Computing MIN */ + i__1 = *kmax, i__2 = minmn - nx; + jmaxb = f2cmin(i__1,i__2); + + if (nb >= nbmin && nb < jmax && jmaxb > 0) { + +/* Loop over the column blocks of the matrix A(1:M,1:JMAXB). Here: */ +/* J is the column index of a column block; */ +/* JB is the column block size to pass to block factorization */ +/* routine in a loop step; */ +/* JBF is the number of columns that were actually factorized */ +/* that was returned by the block factorization routine */ +/* in a loop step, JBF <= JB; */ +/* N_SUB is the number of columns in the submatrix; */ +/* IOFFSET is the number of rows that should not be factorized. */ + + while(j <= jmaxb) { + +/* Computing MIN */ + i__1 = nb, i__2 = jmaxb - j + 1; + jb = f2cmin(i__1,i__2); + n_sub__ = *n - j + 1; + ioffset = j - 1; + +/* Factorize JB columns among the columns A(J:N). */ + + i__1 = *n + *nrhs - j + 1; + dlaqp3rk_(m, &n_sub__, nrhs, &ioffset, &jb, abstol, reltol, &kp1, + &maxc2nrm, &a[j * a_dim1 + 1], lda, &done, &jbf, + maxc2nrmk, relmaxc2nrmk, &jpiv[j], &tau[j], &work[j], & + work[*n + j], &work[(*n << 1) + 1], &work[(*n << 1) + jb + + 1], &i__1, &iwork[1], &iinfo); + +/* Set INFO on the first occurence of Inf. */ + + if (iinfo > n_sub__ && *info == 0) { + *info = (ioffset << 1) + iinfo; + } + + if (done) { + +/* Either the submatrix is zero before the end of the */ +/* column block, or ABSTOL or RELTOL criterion is */ +/* satisfied before the end of the column block, we can */ +/* return from the routine. Perform the following before */ +/* returning: */ +/* a) Set the number of factorized columns K, */ +/* K = IOFFSET + JBF from the last call of blocked */ +/* routine. */ +/* NOTE: 1) MAXC2NRMK and RELMAXC2NRMK are returned */ +/* by the block factorization routine; */ +/* 2) The remaining TAUs are set to ZERO by the */ +/* block factorization routine. */ + + *k = ioffset + jbf; + +/* Set INFO on the first occurrence of NaN, NaN takes */ +/* prcedence over Inf. */ + + if (iinfo <= n_sub__ && iinfo > 0) { + *info = ioffset + iinfo; + } + +/* Return from the routine. */ + + work[1] = (doublereal) lwkopt; + + return 0; + + } + + j += jbf; + + } + + } + +/* Use unblocked code to factor the last or only block. */ +/* J = JMAX+1 means we factorized the maximum possible number of */ +/* columns, that is in ELSE clause we need to compute */ +/* the MAXC2NORM and RELMAXC2NORM to return after we processed */ +/* the blocks. */ + + if (j <= jmax) { + +/* N_SUB is the number of columns in the submatrix; */ +/* IOFFSET is the number of rows that should not be factorized. */ + + n_sub__ = *n - j + 1; + ioffset = j - 1; + + i__1 = jmax - j + 1; + dlaqp2rk_(m, &n_sub__, nrhs, &ioffset, &i__1, abstol, reltol, &kp1, & + maxc2nrm, &a[j * a_dim1 + 1], lda, &kf, maxc2nrmk, + relmaxc2nrmk, &jpiv[j], &tau[j], &work[j], &work[*n + j], & + work[(*n << 1) + 1], &iinfo); + +/* ABSTOL or RELTOL criterion is satisfied when the number of */ +/* the factorized columns KF is smaller then the number */ +/* of columns JMAX-J+1 supplied to be factorized by the */ +/* unblocked routine, we can return from */ +/* the routine. Perform the following before returning: */ +/* a) Set the number of factorized columns K, */ +/* b) MAXC2NRMK and RELMAXC2NRMK are returned by the */ +/* unblocked factorization routine above. */ + + *k = j - 1 + kf; + +/* Set INFO on the first exception occurence. */ + +/* Set INFO on the first exception occurence of Inf or NaN, */ +/* (NaN takes precedence over Inf). */ + + if (iinfo > n_sub__ && *info == 0) { + *info = (ioffset << 1) + iinfo; + } else if (iinfo <= n_sub__ && iinfo > 0) { + *info = ioffset + iinfo; + } + + } else { + +/* Compute the return values for blocked code. */ + +/* Set the number of factorized columns if the unblocked routine */ +/* was not called. */ + + *k = jmax; + +/* If there exits a residual matrix after the blocked code: */ +/* 1) compute the values of MAXC2NRMK, RELMAXC2NRMK of the */ +/* residual matrix, otherwise set them to ZERO; */ +/* 2) Set TAU(K+1:MINMN) to ZERO. */ + + if (*k < minmn) { + i__1 = *n - *k; + jmaxc2nrm = *k + idamax_(&i__1, &work[*k + 1], &c__1); + *maxc2nrmk = work[jmaxc2nrm]; + if (*k == 0) { + *relmaxc2nrmk = 1.; + } else { + *relmaxc2nrmk = *maxc2nrmk / maxc2nrm; + } + + i__1 = minmn; + for (j = *k + 1; j <= i__1; ++j) { + tau[j] = 0.; + } + + } + +/* END IF( J.LE.JMAX ) THEN */ + + } + + work[1] = (doublereal) lwkopt; + + return 0; + +/* End of DGEQP3RK */ + +} /* dgeqp3rk_ */ + diff --git a/lapack-netlib/SRC/dlaqp2rk.c b/lapack-netlib/SRC/dlaqp2rk.c new file mode 100644 index 000000000..de216ad97 --- /dev/null +++ b/lapack-netlib/SRC/dlaqp2rk.c @@ -0,0 +1,923 @@ +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +#if defined(_WIN64) +typedef long long BLASLONG; +typedef unsigned long long BLASULONG; +#else +typedef long BLASLONG; +typedef unsigned long BLASULONG; +#endif + +#ifdef LAPACK_ILP64 +typedef BLASLONG blasint; +#if defined(_WIN64) +#define blasabs(x) llabs(x) +#else +#define blasabs(x) labs(x) +#endif +#else +typedef int blasint; +#define blasabs(x) abs(x) +#endif + +typedef blasint integer; + +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +#ifdef _MSC_VER +static inline _Fcomplex Cf(complex *z) {_Fcomplex zz={z->r , z->i}; return zz;} +static inline _Dcomplex Cd(doublecomplex *z) {_Dcomplex zz={z->r , z->i};return zz;} +static inline _Fcomplex * _pCf(complex *z) {return (_Fcomplex*)z;} +static inline _Dcomplex * _pCd(doublecomplex *z) {return (_Dcomplex*)z;} +#else +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#endif +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#ifdef _MSC_VER +#define c_div(c, a, b) {Cf(c)._Val[0] = (Cf(a)._Val[0]/Cf(b)._Val[0]); Cf(c)._Val[1]=(Cf(a)._Val[1]/Cf(b)._Val[1]);} +#define z_div(c, a, b) {Cd(c)._Val[0] = (Cd(a)._Val[0]/Cd(b)._Val[0]); Cd(c)._Val[1]=(Cd(a)._Val[1]/Cd(b)._Val[1]);} +#else +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#endif +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conjf(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimagf(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) {ceil(w)} +#define myhuge_(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +#ifdef _MSC_VER +static _Fcomplex cpow_ui(complex x, integer n) { + complex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x.r = 1/x.r, x.i=1/x.i; + for(u = n; ; ) { + if(u & 01) pow.r *= x.r, pow.i *= x.i; + if(u >>= 1) x.r *= x.r, x.i *= x.i; + else break; + } + } + _Fcomplex p={pow.r, pow.i}; + return p; +} +#else +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +#endif +#ifdef _MSC_VER +static _Dcomplex zpow_ui(_Dcomplex x, integer n) { + _Dcomplex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x._Val[0] = 1/x._Val[0], x._Val[1] =1/x._Val[1]; + for(u = n; ; ) { + if(u & 01) pow._Val[0] *= x._Val[0], pow._Val[1] *= x._Val[1]; + if(u >>= 1) x._Val[0] *= x._Val[0], x._Val[1] *= x._Val[1]; + else break; + } + } + _Dcomplex p = {pow._Val[0], pow._Val[1]}; + return p; +} +#else +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +#endif +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; +#ifdef _MSC_VER + _Fcomplex zdotc = {0.0, 0.0}; + if (incx == 1 && incy == 1) { + for (i=0;i myhugeval) { + *info = *n + kk - 1 + kp; + } + +/* ============================================================ */ + +/* Test for the second and third stopping criteria. */ +/* NOTE: There is no need to test for ABSTOL >= ZERO, since */ +/* MAXC2NRMK is non-negative. Similarly, there is no need */ +/* to test for RELTOL >= ZERO, since RELMAXC2NRMK is */ +/* non-negative. */ +/* We need to check the condition only if the */ +/* column index (same as row index) of the original whole */ +/* matrix is larger than 1, since the condition for whole */ +/* original matrix is checked in the main routine. */ + *relmaxc2nrmk = *maxc2nrmk / *maxc2nrm; + + if (*maxc2nrmk <= *abstol || *relmaxc2nrmk <= *reltol) { + +/* Set K, the number of factorized columns. */ + + *k = kk - 1; + +/* Set TAUs corresponding to the columns that were not */ +/* factorized to ZERO, i.e. set TAU(KK:MINMNFACT) to ZERO. */ + + i__2 = minmnfact; + for (j = kk; j <= i__2; ++j) { + tau[j] = 0.; + } + +/* Return from the routine. */ + + return 0; + + } + +/* ============================================================ */ + +/* End ELSE of IF(I.EQ.1) */ + + } + +/* =============================================================== */ + +/* If the pivot column is not the first column of the */ +/* subblock A(1:M,KK:N): */ +/* 1) swap the KK-th column and the KP-th pivot column */ +/* in A(1:M,1:N); */ +/* 2) copy the KK-th element into the KP-th element of the partial */ +/* and exact 2-norm vectors VN1 and VN2. ( Swap is not needed */ +/* for VN1 and VN2 since we use the element with the index */ +/* larger than KK in the next loop step.) */ +/* 3) Save the pivot interchange with the indices relative to the */ +/* the original matrix A, not the block A(1:M,1:N). */ + + if (kp != kk) { + dswap_(m, &a[kp * a_dim1 + 1], &c__1, &a[kk * a_dim1 + 1], &c__1); + vn1[kp] = vn1[kk]; + vn2[kp] = vn2[kk]; + itemp = jpiv[kp]; + jpiv[kp] = jpiv[kk]; + jpiv[kk] = itemp; + } + +/* Generate elementary reflector H(KK) using the column A(I:M,KK), */ +/* if the column has more than one element, otherwise */ +/* the elementary reflector would be an identity matrix, */ +/* and TAU(KK) = ZERO. */ + + if (i__ < *m) { + i__2 = *m - i__ + 1; + dlarfg_(&i__2, &a[i__ + kk * a_dim1], &a[i__ + 1 + kk * a_dim1], & + c__1, &tau[kk]); + } else { + tau[kk] = 0.; + } + +/* Check if TAU(KK) contains NaN, set INFO parameter */ +/* to the column number where NaN is found and return from */ +/* the routine. */ +/* NOTE: There is no need to check TAU(KK) for Inf, */ +/* since DLARFG cannot produce TAU(KK) or Householder vector */ +/* below the diagonal containing Inf. Only BETA on the diagonal, */ +/* returned by DLARFG can contain Inf, which requires */ +/* TAU(KK) to contain NaN. Therefore, this case of generating Inf */ +/* by DLARFG is covered by checking TAU(KK) for NaN. */ + + if (disnan_(&tau[kk])) { + *k = kk - 1; + *info = kk; + +/* Set MAXC2NRMK and RELMAXC2NRMK to NaN. */ + + *maxc2nrmk = tau[kk]; + *relmaxc2nrmk = tau[kk]; + +/* Array TAU(KK:MINMNFACT) is not set and contains */ +/* undefined elements, except the first element TAU(KK) = NaN. */ + + return 0; + } + +/* Apply H(KK)**T to A(I:M,KK+1:N+NRHS) from the left. */ +/* ( If M >= N, then at KK = N there is no residual matrix, */ +/* i.e. no columns of A to update, only columns of B. */ +/* If M < N, then at KK = M-IOFFSET, I = M and we have a */ +/* one-row residual matrix in A and the elementary */ +/* reflector is a unit matrix, TAU(KK) = ZERO, i.e. no update */ +/* is needed for the residual matrix in A and the */ +/* right-hand-side-matrix in B. */ +/* Therefore, we update only if */ +/* KK < MINMNUPDT = f2cmin(M-IOFFSET, N+NRHS) */ +/* condition is satisfied, not only KK < N+NRHS ) */ + + if (kk < minmnupdt) { + aikk = a[i__ + kk * a_dim1]; + a[i__ + kk * a_dim1] = 1.; + i__2 = *m - i__ + 1; + i__3 = *n + *nrhs - kk; + dlarf_("Left", &i__2, &i__3, &a[i__ + kk * a_dim1], &c__1, &tau[ + kk], &a[i__ + (kk + 1) * a_dim1], lda, &work[1]); + a[i__ + kk * a_dim1] = aikk; + } + + if (kk < minmnfact) { + +/* Update the partial column 2-norms for the residual matrix, */ +/* only if the residual matrix A(I+1:M,KK+1:N) exists, i.e. */ +/* when KK < f2cmin(M-IOFFSET, N). */ + + i__2 = *n; + for (j = kk + 1; j <= i__2; ++j) { + if (vn1[j] != 0.) { + +/* NOTE: The following lines follow from the analysis in */ +/* Lapack Working Note 176. */ + +/* Computing 2nd power */ + d__2 = (d__1 = a[i__ + j * a_dim1], abs(d__1)) / vn1[j]; + temp = 1. - d__2 * d__2; + temp = f2cmax(temp,0.); +/* Computing 2nd power */ + d__1 = vn1[j] / vn2[j]; + temp2 = temp * (d__1 * d__1); + if (temp2 <= tol3z) { + +/* Compute the column 2-norm for the partial */ +/* column A(I+1:M,J) by explicitly computing it, */ +/* and store it in both partial 2-norm vector VN1 */ +/* and exact column 2-norm vector VN2. */ + + i__3 = *m - i__; + vn1[j] = dnrm2_(&i__3, &a[i__ + 1 + j * a_dim1], & + c__1); + vn2[j] = vn1[j]; + + } else { + +/* Update the column 2-norm for the partial */ +/* column A(I+1:M,J) by removing one */ +/* element A(I,J) and store it in partial */ +/* 2-norm vector VN1. */ + + vn1[j] *= sqrt(temp); + + } + } + } + + } + +/* End factorization loop */ + + } + +/* If we reached this point, all colunms have been factorized, */ +/* i.e. no condition was triggered to exit the routine. */ +/* Set the number of factorized columns. */ + + *k = *kmax; + +/* We reached the end of the loop, i.e. all KMAX columns were */ +/* factorized, we need to set MAXC2NRMK and RELMAXC2NRMK before */ +/* we return. */ + + if (*k < minmnfact) { + + i__1 = *n - *k; + jmaxc2nrm = *k + idamax_(&i__1, &vn1[*k + 1], &c__1); + *maxc2nrmk = vn1[jmaxc2nrm]; + + if (*k == 0) { + *relmaxc2nrmk = 1.; + } else { + *relmaxc2nrmk = *maxc2nrmk / *maxc2nrm; + } + + } else { + *maxc2nrmk = 0.; + *relmaxc2nrmk = 0.; + } + +/* We reached the end of the loop, i.e. all KMAX columns were */ +/* factorized, set TAUs corresponding to the columns that were */ +/* not factorized to ZERO, i.e. TAU(K+1:MINMNFACT) set to ZERO. */ + + i__1 = minmnfact; + for (j = *k + 1; j <= i__1; ++j) { + tau[j] = 0.; + } + + return 0; + +/* End of DLAQP2RK */ + +} /* dlaqp2rk_ */ + diff --git a/lapack-netlib/SRC/dlaqp3rk.c b/lapack-netlib/SRC/dlaqp3rk.c new file mode 100644 index 000000000..e8c61c257 --- /dev/null +++ b/lapack-netlib/SRC/dlaqp3rk.c @@ -0,0 +1,1113 @@ +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +#if defined(_WIN64) +typedef long long BLASLONG; +typedef unsigned long long BLASULONG; +#else +typedef long BLASLONG; +typedef unsigned long BLASULONG; +#endif + +#ifdef LAPACK_ILP64 +typedef BLASLONG blasint; +#if defined(_WIN64) +#define blasabs(x) llabs(x) +#else +#define blasabs(x) labs(x) +#endif +#else +typedef int blasint; +#define blasabs(x) abs(x) +#endif + +typedef blasint integer; + +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +#ifdef _MSC_VER +static inline _Fcomplex Cf(complex *z) {_Fcomplex zz={z->r , z->i}; return zz;} +static inline _Dcomplex Cd(doublecomplex *z) {_Dcomplex zz={z->r , z->i};return zz;} +static inline _Fcomplex * _pCf(complex *z) {return (_Fcomplex*)z;} +static inline _Dcomplex * _pCd(doublecomplex *z) {return (_Dcomplex*)z;} +#else +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#endif +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#ifdef _MSC_VER +#define c_div(c, a, b) {Cf(c)._Val[0] = (Cf(a)._Val[0]/Cf(b)._Val[0]); Cf(c)._Val[1]=(Cf(a)._Val[1]/Cf(b)._Val[1]);} +#define z_div(c, a, b) {Cd(c)._Val[0] = (Cd(a)._Val[0]/Cd(b)._Val[0]); Cd(c)._Val[1]=(Cd(a)._Val[1]/Cd(b)._Val[1]);} +#else +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#endif +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conjf(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimagf(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) {ceil(w)} +#define myhuge_(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +#ifdef _MSC_VER +static _Fcomplex cpow_ui(complex x, integer n) { + complex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x.r = 1/x.r, x.i=1/x.i; + for(u = n; ; ) { + if(u & 01) pow.r *= x.r, pow.i *= x.i; + if(u >>= 1) x.r *= x.r, x.i *= x.i; + else break; + } + } + _Fcomplex p={pow.r, pow.i}; + return p; +} +#else +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +#endif +#ifdef _MSC_VER +static _Dcomplex zpow_ui(_Dcomplex x, integer n) { + _Dcomplex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x._Val[0] = 1/x._Val[0], x._Val[1] =1/x._Val[1]; + for(u = n; ; ) { + if(u & 01) pow._Val[0] *= x._Val[0], pow._Val[1] *= x._Val[1]; + if(u >>= 1) x._Val[0] *= x._Val[0], x._Val[1] *= x._Val[1]; + else break; + } + } + _Dcomplex p = {pow._Val[0], pow._Val[1]}; + return p; +} +#else +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +#endif +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; +#ifdef _MSC_VER + _Fcomplex zdotc = {0.0, 0.0}; + if (incx == 1 && incy == 1) { + for (i=0;i 0 && *kb < *m - *ioffset) { + i__1 = *m - if__; + dgemm_("No transpose", "Transpose", &i__1, nrhs, kb, & + c_b7, &a[if__ + 1 + a_dim1], lda, &f[*n + 1 + + f_dim1], ldf, &c_b8, &a[if__ + 1 + (*n + 1) * + a_dim1], lda); + } + +/* There is no need to recompute the 2-norm of the */ +/* difficult columns, since we stop the factorization. */ + +/* Array TAU(KF+1:MINMNFACT) is not set and contains */ +/* undefined elements. */ + +/* Return from the routine. */ + + return 0; + } + +/* Quick return, if the submatrix A(I:M,K:N) is */ +/* a zero matrix. We need to check it only if the column index */ +/* (same as row index) is larger than 1, since the condition */ +/* for the whole original matrix A_orig is checked in the main */ +/* routine. */ + + if (*maxc2nrmk == 0.) { + + *done = TRUE_; + +/* Set KB, the number of factorized partial columns */ +/* that are non-zero in each step in the block, */ +/* i.e. the rank of the factor R. */ +/* Set IF, the number of processed rows in the block, which */ +/* is the same as the number of processed rows in */ +/* the original whole matrix A_orig. */ + + *kb = k - 1; + if__ = i__ - 1; + *relmaxc2nrmk = 0.; + +/* There is no need to apply the block reflector to the */ +/* residual of the matrix A stored in A(KB+1:M,KB+1:N), */ +/* since the submatrix is zero and we stop the computation. */ +/* But, we need to apply the block reflector to the residual */ +/* right hand sides stored in A(KB+1:M,N+1:N+NRHS), if the */ +/* residual right hand sides exist. This occurs */ +/* when ( NRHS != 0 AND KB <= (M-IOFFSET) ): */ + +/* A(I+1:M,N+1:N+NRHS) := A(I+1:M,N+1:N+NRHS) - */ +/* A(I+1:M,1:KB) * F(N+1:N+NRHS,1:KB)**T. */ + + if (*nrhs > 0 && *kb < *m - *ioffset) { + i__1 = *m - if__; + dgemm_("No transpose", "Transpose", &i__1, nrhs, kb, & + c_b7, &a[if__ + 1 + a_dim1], lda, &f[*n + 1 + + f_dim1], ldf, &c_b8, &a[if__ + 1 + (*n + 1) * + a_dim1], lda); + } + +/* There is no need to recompute the 2-norm of the */ +/* difficult columns, since we stop the factorization. */ + +/* Set TAUs corresponding to the columns that were not */ +/* factorized to ZERO, i.e. set TAU(KB+1:MINMNFACT) = ZERO, */ +/* which is equivalent to seting TAU(K:MINMNFACT) = ZERO. */ + + i__1 = minmnfact; + for (j = k; j <= i__1; ++j) { + tau[j] = 0.; + } + +/* Return from the routine. */ + + return 0; + + } + +/* ============================================================ */ + +/* Check if the submatrix A(I:M,K:N) contains Inf, */ +/* set INFO parameter to the column number, where */ +/* the first Inf is found plus N, and continue */ +/* the computation. */ +/* We need to check the condition only if the */ +/* column index (same as row index) of the original whole */ +/* matrix is larger than 1, since the condition for whole */ +/* original matrix is checked in the main routine. */ + + if (*info == 0 && *maxc2nrmk > myhugeval) { + *info = *n + k - 1 + kp; + } + +/* ============================================================ */ + +/* Test for the second and third tolerance stopping criteria. */ +/* NOTE: There is no need to test for ABSTOL.GE.ZERO, since */ +/* MAXC2NRMK is non-negative. Similarly, there is no need */ +/* to test for RELTOL.GE.ZERO, since RELMAXC2NRMK is */ +/* non-negative. */ +/* We need to check the condition only if the */ +/* column index (same as row index) of the original whole */ +/* matrix is larger than 1, since the condition for whole */ +/* original matrix is checked in the main routine. */ + + *relmaxc2nrmk = *maxc2nrmk / *maxc2nrm; + + if (*maxc2nrmk <= *abstol || *relmaxc2nrmk <= *reltol) { + + *done = TRUE_; + +/* Set KB, the number of factorized partial columns */ +/* that are non-zero in each step in the block, */ +/* i.e. the rank of the factor R. */ +/* Set IF, the number of processed rows in the block, which */ +/* is the same as the number of processed rows in */ +/* the original whole matrix A_orig; */ + + *kb = k - 1; + if__ = i__ - 1; + +/* Apply the block reflector to the residual of the */ +/* matrix A and the residual of the right hand sides B, if */ +/* the residual matrix and and/or the residual of the right */ +/* hand sides exist, i.e. if the submatrix */ +/* A(I+1:M,KB+1:N+NRHS) exists. This occurs when */ +/* KB < MINMNUPDT = f2cmin( M-IOFFSET, N+NRHS ): */ + +/* A(IF+1:M,K+1:N+NRHS) := A(IF+1:M,KB+1:N+NRHS) - */ +/* A(IF+1:M,1:KB) * F(KB+1:N+NRHS,1:KB)**T. */ + + if (*kb < minmnupdt) { + i__1 = *m - if__; + i__2 = *n + *nrhs - *kb; + dgemm_("No transpose", "Transpose", &i__1, &i__2, kb, & + c_b7, &a[if__ + 1 + a_dim1], lda, &f[*kb + 1 + + f_dim1], ldf, &c_b8, &a[if__ + 1 + (*kb + 1) * + a_dim1], lda); + } + +/* There is no need to recompute the 2-norm of the */ +/* difficult columns, since we stop the factorization. */ + +/* Set TAUs corresponding to the columns that were not */ +/* factorized to ZERO, i.e. set TAU(KB+1:MINMNFACT) = ZERO, */ +/* which is equivalent to seting TAU(K:MINMNFACT) = ZERO. */ + + i__1 = minmnfact; + for (j = k; j <= i__1; ++j) { + tau[j] = 0.; + } + +/* Return from the routine. */ + + return 0; + + } + +/* ============================================================ */ + +/* End ELSE of IF(I.EQ.1) */ + + } + +/* =============================================================== */ + +/* If the pivot column is not the first column of the */ +/* subblock A(1:M,K:N): */ +/* 1) swap the K-th column and the KP-th pivot column */ +/* in A(1:M,1:N); */ +/* 2) swap the K-th row and the KP-th row in F(1:N,1:K-1) */ +/* 3) copy the K-th element into the KP-th element of the partial */ +/* and exact 2-norm vectors VN1 and VN2. (Swap is not needed */ +/* for VN1 and VN2 since we use the element with the index */ +/* larger than K in the next loop step.) */ +/* 4) Save the pivot interchange with the indices relative to the */ +/* the original matrix A_orig, not the block A(1:M,1:N). */ + + if (kp != k) { + dswap_(m, &a[kp * a_dim1 + 1], &c__1, &a[k * a_dim1 + 1], &c__1); + i__1 = k - 1; + dswap_(&i__1, &f[kp + f_dim1], ldf, &f[k + f_dim1], ldf); + vn1[kp] = vn1[k]; + vn2[kp] = vn2[k]; + itemp = jpiv[kp]; + jpiv[kp] = jpiv[k]; + jpiv[k] = itemp; + } + +/* Apply previous Householder reflectors to column K: */ +/* A(I:M,K) := A(I:M,K) - A(I:M,1:K-1)*F(K,1:K-1)**T. */ + + if (k > 1) { + i__1 = *m - i__ + 1; + i__2 = k - 1; + dgemv_("No transpose", &i__1, &i__2, &c_b7, &a[i__ + a_dim1], lda, + &f[k + f_dim1], ldf, &c_b8, &a[i__ + k * a_dim1], &c__1); + } + +/* Generate elementary reflector H(k) using the column A(I:M,K). */ + + if (i__ < *m) { + i__1 = *m - i__ + 1; + dlarfg_(&i__1, &a[i__ + k * a_dim1], &a[i__ + 1 + k * a_dim1], & + c__1, &tau[k]); + } else { + tau[k] = 0.; + } + +/* Check if TAU(K) contains NaN, set INFO parameter */ +/* to the column number where NaN is found and return from */ +/* the routine. */ +/* NOTE: There is no need to check TAU(K) for Inf, */ +/* since DLARFG cannot produce TAU(K) or Householder vector */ +/* below the diagonal containing Inf. Only BETA on the diagonal, */ +/* returned by DLARFG can contain Inf, which requires */ +/* TAU(K) to contain NaN. Therefore, this case of generating Inf */ +/* by DLARFG is covered by checking TAU(K) for NaN. */ + + if (disnan_(&tau[k])) { + + *done = TRUE_; + +/* Set KB, the number of factorized partial columns */ +/* that are non-zero in each step in the block, */ +/* i.e. the rank of the factor R. */ +/* Set IF, the number of processed rows in the block, which */ +/* is the same as the number of processed rows in */ +/* the original whole matrix A_orig. */ + + *kb = k - 1; + if__ = i__ - 1; + *info = k; + +/* Set MAXC2NRMK and RELMAXC2NRMK to NaN. */ + + *maxc2nrmk = tau[k]; + *relmaxc2nrmk = tau[k]; + +/* There is no need to apply the block reflector to the */ +/* residual of the matrix A stored in A(KB+1:M,KB+1:N), */ +/* since the submatrix contains NaN and we stop */ +/* the computation. */ +/* But, we need to apply the block reflector to the residual */ +/* right hand sides stored in A(KB+1:M,N+1:N+NRHS), if the */ +/* residual right hand sides exist. This occurs */ +/* when ( NRHS != 0 AND KB <= (M-IOFFSET) ): */ + +/* A(I+1:M,N+1:N+NRHS) := A(I+1:M,N+1:N+NRHS) - */ +/* A(I+1:M,1:KB) * F(N+1:N+NRHS,1:KB)**T. */ + + if (*nrhs > 0 && *kb < *m - *ioffset) { + i__1 = *m - if__; + dgemm_("No transpose", "Transpose", &i__1, nrhs, kb, &c_b7, & + a[if__ + 1 + a_dim1], lda, &f[*n + 1 + f_dim1], ldf, & + c_b8, &a[if__ + 1 + (*n + 1) * a_dim1], lda); + } + +/* There is no need to recompute the 2-norm of the */ +/* difficult columns, since we stop the factorization. */ + +/* Array TAU(KF+1:MINMNFACT) is not set and contains */ +/* undefined elements. */ + +/* Return from the routine. */ + + return 0; + } + +/* =============================================================== */ + + aik = a[i__ + k * a_dim1]; + a[i__ + k * a_dim1] = 1.; + +/* =============================================================== */ + +/* Compute the current K-th column of F: */ +/* 1) F(K+1:N,K) := tau(K) * A(I:M,K+1:N)**T * A(I:M,K). */ + + if (k < *n + *nrhs) { + i__1 = *m - i__ + 1; + i__2 = *n + *nrhs - k; + dgemv_("Transpose", &i__1, &i__2, &tau[k], &a[i__ + (k + 1) * + a_dim1], lda, &a[i__ + k * a_dim1], &c__1, &c_b30, &f[k + + 1 + k * f_dim1], &c__1); + } + +/* 2) Zero out elements above and on the diagonal of the */ +/* column K in matrix F, i.e elements F(1:K,K). */ + + i__1 = k; + for (j = 1; j <= i__1; ++j) { + f[j + k * f_dim1] = 0.; + } + +/* 3) Incremental updating of the K-th column of F: */ +/* F(1:N,K) := F(1:N,K) - tau(K) * F(1:N,1:K-1) * A(I:M,1:K-1)**T */ +/* * A(I:M,K). */ + + if (k > 1) { + i__1 = *m - i__ + 1; + i__2 = k - 1; + d__1 = -tau[k]; + dgemv_("Transpose", &i__1, &i__2, &d__1, &a[i__ + a_dim1], lda, & + a[i__ + k * a_dim1], &c__1, &c_b30, &auxv[1], &c__1); + + i__1 = *n + *nrhs; + i__2 = k - 1; + dgemv_("No transpose", &i__1, &i__2, &c_b8, &f[f_dim1 + 1], ldf, & + auxv[1], &c__1, &c_b8, &f[k * f_dim1 + 1], &c__1); + } + +/* =============================================================== */ + +/* Update the current I-th row of A: */ +/* A(I,K+1:N+NRHS) := A(I,K+1:N+NRHS) */ +/* - A(I,1:K)*F(K+1:N+NRHS,1:K)**T. */ + + if (k < *n + *nrhs) { + i__1 = *n + *nrhs - k; + dgemv_("No transpose", &i__1, &k, &c_b7, &f[k + 1 + f_dim1], ldf, + &a[i__ + a_dim1], lda, &c_b8, &a[i__ + (k + 1) * a_dim1], + lda); + } + + a[i__ + k * a_dim1] = aik; + +/* Update the partial column 2-norms for the residual matrix, */ +/* only if the residual matrix A(I+1:M,K+1:N) exists, i.e. */ +/* when K < MINMNFACT = f2cmin( M-IOFFSET, N ). */ + + if (k < minmnfact) { + + i__1 = *n; + for (j = k + 1; j <= i__1; ++j) { + if (vn1[j] != 0.) { + +/* NOTE: The following lines follow from the analysis in */ +/* Lapack Working Note 176. */ + + temp = (d__1 = a[i__ + j * a_dim1], abs(d__1)) / vn1[j]; +/* Computing MAX */ + d__1 = 0., d__2 = (temp + 1.) * (1. - temp); + temp = f2cmax(d__1,d__2); +/* Computing 2nd power */ + d__1 = vn1[j] / vn2[j]; + temp2 = temp * (d__1 * d__1); + if (temp2 <= tol3z) { + +/* At J-index, we have a difficult column for the */ +/* update of the 2-norm. Save the index of the previous */ +/* difficult column in IWORK(J-1). */ +/* NOTE: ILSTCC > 1, threfore we can use IWORK only */ +/* with N-1 elements, where the elements are */ +/* shifted by 1 to the left. */ + + iwork[j - 1] = lsticc; + +/* Set the index of the last difficult column LSTICC. */ + + lsticc = j; + + } else { + vn1[j] *= sqrt(temp); + } + } + } + + } + +/* End of while loop. */ + + } + +/* Now, afler the loop: */ +/* Set KB, the number of factorized columns in the block; */ +/* Set IF, the number of processed rows in the block, which */ +/* is the same as the number of processed rows in */ +/* the original whole matrix A_orig, IF = IOFFSET + KB. */ + + *kb = k; + if__ = i__; + +/* Apply the block reflector to the residual of the matrix A */ +/* and the residual of the right hand sides B, if the residual */ +/* matrix and and/or the residual of the right hand sides */ +/* exist, i.e. if the submatrix A(I+1:M,KB+1:N+NRHS) exists. */ +/* This occurs when KB < MINMNUPDT = f2cmin( M-IOFFSET, N+NRHS ): */ + +/* A(IF+1:M,K+1:N+NRHS) := A(IF+1:M,KB+1:N+NRHS) - */ +/* A(IF+1:M,1:KB) * F(KB+1:N+NRHS,1:KB)**T. */ + + if (*kb < minmnupdt) { + i__1 = *m - if__; + i__2 = *n + *nrhs - *kb; + dgemm_("No transpose", "Transpose", &i__1, &i__2, kb, &c_b7, &a[if__ + + 1 + a_dim1], lda, &f[*kb + 1 + f_dim1], ldf, &c_b8, &a[if__ + + 1 + (*kb + 1) * a_dim1], lda); + } + +/* Recompute the 2-norm of the difficult columns. */ +/* Loop over the index of the difficult columns from the largest */ +/* to the smallest index. */ + + while(lsticc > 0) { + +/* LSTICC is the index of the last difficult column is greater */ +/* than 1. */ +/* ITEMP is the index of the previous difficult column. */ + + itemp = iwork[lsticc - 1]; + +/* Compute the 2-norm explicilty for the last difficult column and */ +/* save it in the partial and exact 2-norm vectors VN1 and VN2. */ + +/* NOTE: The computation of VN1( LSTICC ) relies on the fact that */ +/* DNRM2 does not fail on vectors with norm below the value of */ +/* SQRT(DLAMCH('S')) */ + + i__1 = *m - if__; + vn1[lsticc] = dnrm2_(&i__1, &a[if__ + 1 + lsticc * a_dim1], &c__1); + vn2[lsticc] = vn1[lsticc]; + +/* Downdate the index of the last difficult column to */ +/* the index of the previous difficult column. */ + + lsticc = itemp; + + } + + return 0; + +/* End of DLAQP3RK */ + +} /* dlaqp3rk_ */ + diff --git a/lapack-netlib/SRC/sgeqp3rk.c b/lapack-netlib/SRC/sgeqp3rk.c new file mode 100644 index 000000000..fe52901bf --- /dev/null +++ b/lapack-netlib/SRC/sgeqp3rk.c @@ -0,0 +1,1055 @@ +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +#if defined(_WIN64) +typedef long long BLASLONG; +typedef unsigned long long BLASULONG; +#else +typedef long BLASLONG; +typedef unsigned long BLASULONG; +#endif + +#ifdef LAPACK_ILP64 +typedef BLASLONG blasint; +#if defined(_WIN64) +#define blasabs(x) llabs(x) +#else +#define blasabs(x) labs(x) +#endif +#else +typedef int blasint; +#define blasabs(x) abs(x) +#endif + +typedef blasint integer; + +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +#ifdef _MSC_VER +static inline _Fcomplex Cf(complex *z) {_Fcomplex zz={z->r , z->i}; return zz;} +static inline _Dcomplex Cd(doublecomplex *z) {_Dcomplex zz={z->r , z->i};return zz;} +static inline _Fcomplex * _pCf(complex *z) {return (_Fcomplex*)z;} +static inline _Dcomplex * _pCd(doublecomplex *z) {return (_Dcomplex*)z;} +#else +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#endif +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#ifdef _MSC_VER +#define c_div(c, a, b) {Cf(c)._Val[0] = (Cf(a)._Val[0]/Cf(b)._Val[0]); Cf(c)._Val[1]=(Cf(a)._Val[1]/Cf(b)._Val[1]);} +#define z_div(c, a, b) {Cd(c)._Val[0] = (Cd(a)._Val[0]/Cd(b)._Val[0]); Cd(c)._Val[1]=(Cd(a)._Val[1]/Cd(b)._Val[1]);} +#else +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#endif +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conjf(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimagf(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) {ceil(w)} +#define myhuge_(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +#ifdef _MSC_VER +static _Fcomplex cpow_ui(complex x, integer n) { + complex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x.r = 1/x.r, x.i=1/x.i; + for(u = n; ; ) { + if(u & 01) pow.r *= x.r, pow.i *= x.i; + if(u >>= 1) x.r *= x.r, x.i *= x.i; + else break; + } + } + _Fcomplex p={pow.r, pow.i}; + return p; +} +#else +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +#endif +#ifdef _MSC_VER +static _Dcomplex zpow_ui(_Dcomplex x, integer n) { + _Dcomplex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x._Val[0] = 1/x._Val[0], x._Val[1] =1/x._Val[1]; + for(u = n; ; ) { + if(u & 01) pow._Val[0] *= x._Val[0], pow._Val[1] *= x._Val[1]; + if(u >>= 1) x._Val[0] *= x._Val[0], x._Val[1] *= x._Val[1]; + else break; + } + } + _Dcomplex p = {pow._Val[0], pow._Val[1]}; + return p; +} +#else +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +#endif +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; +#ifdef _MSC_VER + _Fcomplex zdotc = {0.0, 0.0}; + if (incx == 1 && incy == 1) { + for (i=0;i myhugeval) { + +/* Check if the matrix A contains +Inf or -Inf, set INFO parameter */ +/* to the column number, where the first +/-Inf is found plus N, */ +/* and continue the computation. */ + + *info = *n + kp1; + + } + +/* ================================================================== */ + +/* Quick return if possible for the case when the first */ +/* stopping criterion is satisfied, i.e. KMAX = 0. */ + + if (*kmax == 0) { + *k = 0; + *maxc2nrmk = maxc2nrm; + *relmaxc2nrmk = 1.f; + i__1 = minmn; + for (j = 1; j <= i__1; ++j) { + tau[j] = 0.f; + } + work[1] = (real) lwkopt; + return 0; + } + +/* ================================================================== */ + + eps = slamch_("Epsilon"); + +/* Adjust ABSTOL */ + + if (*abstol >= 0.f) { + safmin = slamch_("Safe minimum"); +/* Computing MAX */ + r__1 = *abstol, r__2 = safmin * 2.f; + *abstol = f2cmax(r__1,r__2); + } + +/* Adjust RELTOL */ + + if (*reltol >= 0.f) { + *reltol = f2cmax(*reltol,eps); + } + +/* =================================================================== */ + +/* JMAX is the maximum index of the column to be factorized, */ +/* which is also limited by the first stopping criterion KMAX. */ + + jmax = f2cmin(*kmax,minmn); + +/* =================================================================== */ + +/* Quick return if possible for the case when the second or third */ +/* stopping criterion for the whole original matrix is satified, */ +/* i.e. MAXC2NRM <= ABSTOL or RELMAXC2NRM <= RELTOL */ +/* (which is ONE <= RELTOL). */ + + if (maxc2nrm <= *abstol || 1.f <= *reltol) { + + *k = 0; + *maxc2nrmk = maxc2nrm; + *relmaxc2nrmk = 1.f; + + i__1 = minmn; + for (j = 1; j <= i__1; ++j) { + tau[j] = 0.f; + } + + work[1] = (real) lwkopt; + return 0; + } + +/* ================================================================== */ +/* Factorize columns */ +/* ================================================================== */ + +/* Determine the block size. */ + + nbmin = 2; + nx = 0; + + if (nb > 1 && nb < minmn) { + +/* Determine when to cross over from blocked to unblocked code. */ +/* (for N less than NX, unblocked code should be used). */ + +/* Computing MAX */ + i__1 = 0, i__2 = ilaenv_(&c__3, "SGEQP3RK", " ", m, n, &c_n1, &c_n1, ( + ftnlen)8, (ftnlen)1); + nx = f2cmax(i__1,i__2); + + if (nx < minmn) { + +/* Determine if workspace is large enough for blocked code. */ + + if (*lwork < lwkopt) { + +/* Not enough workspace to use optimal block size that */ +/* is currently stored in NB. */ +/* Reduce NB and determine the minimum value of NB. */ + + nb = (*lwork - (*n << 1)) / (*n + 1); +/* Computing MAX */ + i__1 = 2, i__2 = ilaenv_(&c__2, "SGEQP3RK", " ", m, n, &c_n1, + &c_n1, (ftnlen)8, (ftnlen)1); + nbmin = f2cmax(i__1,i__2); + + } + } + } + +/* ================================================================== */ + +/* DONE is the boolean flag to rerpresent the case when the */ +/* factorization completed in the block factorization routine, */ +/* before the end of the block. */ + + done = FALSE_; + +/* J is the column index. */ + + j = 1; + +/* (1) Use blocked code initially. */ + +/* JMAXB is the maximum column index of the block, when the */ +/* blocked code is used, is also limited by the first stopping */ +/* criterion KMAX. */ + +/* Computing MIN */ + i__1 = *kmax, i__2 = minmn - nx; + jmaxb = f2cmin(i__1,i__2); + + if (nb >= nbmin && nb < jmax && jmaxb > 0) { + +/* Loop over the column blocks of the matrix A(1:M,1:JMAXB). Here: */ +/* J is the column index of a column block; */ +/* JB is the column block size to pass to block factorization */ +/* routine in a loop step; */ +/* JBF is the number of columns that were actually factorized */ +/* that was returned by the block factorization routine */ +/* in a loop step, JBF <= JB; */ +/* N_SUB is the number of columns in the submatrix; */ +/* IOFFSET is the number of rows that should not be factorized. */ + + while(j <= jmaxb) { + +/* Computing MIN */ + i__1 = nb, i__2 = jmaxb - j + 1; + jb = f2cmin(i__1,i__2); + n_sub__ = *n - j + 1; + ioffset = j - 1; + +/* Factorize JB columns among the columns A(J:N). */ + + i__1 = *n + *nrhs - j + 1; + slaqp3rk_(m, &n_sub__, nrhs, &ioffset, &jb, abstol, reltol, &kp1, + &maxc2nrm, &a[j * a_dim1 + 1], lda, &done, &jbf, + maxc2nrmk, relmaxc2nrmk, &jpiv[j], &tau[j], &work[j], & + work[*n + j], &work[(*n << 1) + 1], &work[(*n << 1) + jb + + 1], &i__1, &iwork[1], &iinfo); + +/* Set INFO on the first occurence of Inf. */ + + if (iinfo > n_sub__ && *info == 0) { + *info = (ioffset << 1) + iinfo; + } + + if (done) { + +/* Either the submatrix is zero before the end of the */ +/* column block, or ABSTOL or RELTOL criterion is */ +/* satisfied before the end of the column block, we can */ +/* return from the routine. Perform the following before */ +/* returning: */ +/* a) Set the number of factorized columns K, */ +/* K = IOFFSET + JBF from the last call of blocked */ +/* routine. */ +/* NOTE: 1) MAXC2NRMK and RELMAXC2NRMK are returned */ +/* by the block factorization routine; */ +/* 2) The remaining TAUs are set to ZERO by the */ +/* block factorization routine. */ + + *k = ioffset + jbf; + +/* Set INFO on the first occurrence of NaN, NaN takes */ +/* prcedence over Inf. */ + + if (iinfo <= n_sub__ && iinfo > 0) { + *info = ioffset + iinfo; + } + +/* Return from the routine. */ + + work[1] = (real) lwkopt; + + return 0; + + } + + j += jbf; + + } + + } + +/* Use unblocked code to factor the last or only block. */ +/* J = JMAX+1 means we factorized the maximum possible number of */ +/* columns, that is in ELSE clause we need to compute */ +/* the MAXC2NORM and RELMAXC2NORM to return after we processed */ +/* the blocks. */ + + if (j <= jmax) { + +/* N_SUB is the number of columns in the submatrix; */ +/* IOFFSET is the number of rows that should not be factorized. */ + + n_sub__ = *n - j + 1; + ioffset = j - 1; + + i__1 = jmax - j + 1; + slaqp2rk_(m, &n_sub__, nrhs, &ioffset, &i__1, abstol, reltol, &kp1, & + maxc2nrm, &a[j * a_dim1 + 1], lda, &kf, maxc2nrmk, + relmaxc2nrmk, &jpiv[j], &tau[j], &work[j], &work[*n + j], & + work[(*n << 1) + 1], &iinfo); + +/* ABSTOL or RELTOL criterion is satisfied when the number of */ +/* the factorized columns KF is smaller then the number */ +/* of columns JMAX-J+1 supplied to be factorized by the */ +/* unblocked routine, we can return from */ +/* the routine. Perform the following before returning: */ +/* a) Set the number of factorized columns K, */ +/* b) MAXC2NRMK and RELMAXC2NRMK are returned by the */ +/* unblocked factorization routine above. */ + + *k = j - 1 + kf; + +/* Set INFO on the first exception occurence. */ + +/* Set INFO on the first exception occurence of Inf or NaN, */ +/* (NaN takes precedence over Inf). */ + + if (iinfo > n_sub__ && *info == 0) { + *info = (ioffset << 1) + iinfo; + } else if (iinfo <= n_sub__ && iinfo > 0) { + *info = ioffset + iinfo; + } + + } else { + +/* Compute the return values for blocked code. */ + +/* Set the number of factorized columns if the unblocked routine */ +/* was not called. */ + + *k = jmax; + +/* If there exits a residual matrix after the blocked code: */ +/* 1) compute the values of MAXC2NRMK, RELMAXC2NRMK of the */ +/* residual matrix, otherwise set them to ZERO; */ +/* 2) Set TAU(K+1:MINMN) to ZERO. */ + + if (*k < minmn) { + i__1 = *n - *k; + jmaxc2nrm = *k + isamax_(&i__1, &work[*k + 1], &c__1); + *maxc2nrmk = work[jmaxc2nrm]; + if (*k == 0) { + *relmaxc2nrmk = 1.f; + } else { + *relmaxc2nrmk = *maxc2nrmk / maxc2nrm; + } + + i__1 = minmn; + for (j = *k + 1; j <= i__1; ++j) { + tau[j] = 0.f; + } + + } + +/* END IF( J.LE.JMAX ) THEN */ + + } + + work[1] = (real) lwkopt; + + return 0; + +/* End of SGEQP3RK */ + +} /* sgeqp3rk_ */ + diff --git a/lapack-netlib/SRC/slaqp2rk.c b/lapack-netlib/SRC/slaqp2rk.c new file mode 100644 index 000000000..0bfa71ab9 --- /dev/null +++ b/lapack-netlib/SRC/slaqp2rk.c @@ -0,0 +1,918 @@ +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +#if defined(_WIN64) +typedef long long BLASLONG; +typedef unsigned long long BLASULONG; +#else +typedef long BLASLONG; +typedef unsigned long BLASULONG; +#endif + +#ifdef LAPACK_ILP64 +typedef BLASLONG blasint; +#if defined(_WIN64) +#define blasabs(x) llabs(x) +#else +#define blasabs(x) labs(x) +#endif +#else +typedef int blasint; +#define blasabs(x) abs(x) +#endif + +typedef blasint integer; + +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +#ifdef _MSC_VER +static inline _Fcomplex Cf(complex *z) {_Fcomplex zz={z->r , z->i}; return zz;} +static inline _Dcomplex Cd(doublecomplex *z) {_Dcomplex zz={z->r , z->i};return zz;} +static inline _Fcomplex * _pCf(complex *z) {return (_Fcomplex*)z;} +static inline _Dcomplex * _pCd(doublecomplex *z) {return (_Dcomplex*)z;} +#else +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#endif +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#ifdef _MSC_VER +#define c_div(c, a, b) {Cf(c)._Val[0] = (Cf(a)._Val[0]/Cf(b)._Val[0]); Cf(c)._Val[1]=(Cf(a)._Val[1]/Cf(b)._Val[1]);} +#define z_div(c, a, b) {Cd(c)._Val[0] = (Cd(a)._Val[0]/Cd(b)._Val[0]); Cd(c)._Val[1]=(Cd(a)._Val[1]/Cd(b)._Val[1]);} +#else +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#endif +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conjf(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimagf(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) {ceil(w)} +#define myhuge_(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +#ifdef _MSC_VER +static _Fcomplex cpow_ui(complex x, integer n) { + complex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x.r = 1/x.r, x.i=1/x.i; + for(u = n; ; ) { + if(u & 01) pow.r *= x.r, pow.i *= x.i; + if(u >>= 1) x.r *= x.r, x.i *= x.i; + else break; + } + } + _Fcomplex p={pow.r, pow.i}; + return p; +} +#else +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +#endif +#ifdef _MSC_VER +static _Dcomplex zpow_ui(_Dcomplex x, integer n) { + _Dcomplex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x._Val[0] = 1/x._Val[0], x._Val[1] =1/x._Val[1]; + for(u = n; ; ) { + if(u & 01) pow._Val[0] *= x._Val[0], pow._Val[1] *= x._Val[1]; + if(u >>= 1) x._Val[0] *= x._Val[0], x._Val[1] *= x._Val[1]; + else break; + } + } + _Dcomplex p = {pow._Val[0], pow._Val[1]}; + return p; +} +#else +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +#endif +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; +#ifdef _MSC_VER + _Fcomplex zdotc = {0.0, 0.0}; + if (incx == 1 && incy == 1) { + for (i=0;i myhugeval) { + *info = *n + kk - 1 + kp; + } + +/* ============================================================ */ + +/* Test for the second and third stopping criteria. */ +/* NOTE: There is no need to test for ABSTOL >= ZERO, since */ +/* MAXC2NRMK is non-negative. Similarly, there is no need */ +/* to test for RELTOL >= ZERO, since RELMAXC2NRMK is */ +/* non-negative. */ +/* We need to check the condition only if the */ +/* column index (same as row index) of the original whole */ +/* matrix is larger than 1, since the condition for whole */ +/* original matrix is checked in the main routine. */ + *relmaxc2nrmk = *maxc2nrmk / *maxc2nrm; + + if (*maxc2nrmk <= *abstol || *relmaxc2nrmk <= *reltol) { + +/* Set K, the number of factorized columns. */ + + *k = kk - 1; + +/* Set TAUs corresponding to the columns that were not */ +/* factorized to ZERO, i.e. set TAU(KK:MINMNFACT) to ZERO. */ + + i__2 = minmnfact; + for (j = kk; j <= i__2; ++j) { + tau[j] = 0.f; + } + +/* Return from the routine. */ + + return 0; + + } + +/* ============================================================ */ + +/* End ELSE of IF(I.EQ.1) */ + + } + +/* =============================================================== */ + +/* If the pivot column is not the first column of the */ +/* subblock A(1:M,KK:N): */ +/* 1) swap the KK-th column and the KP-th pivot column */ +/* in A(1:M,1:N); */ +/* 2) copy the KK-th element into the KP-th element of the partial */ +/* and exact 2-norm vectors VN1 and VN2. ( Swap is not needed */ +/* for VN1 and VN2 since we use the element with the index */ +/* larger than KK in the next loop step.) */ +/* 3) Save the pivot interchange with the indices relative to the */ +/* the original matrix A, not the block A(1:M,1:N). */ + + if (kp != kk) { + sswap_(m, &a[kp * a_dim1 + 1], &c__1, &a[kk * a_dim1 + 1], &c__1); + vn1[kp] = vn1[kk]; + vn2[kp] = vn2[kk]; + itemp = jpiv[kp]; + jpiv[kp] = jpiv[kk]; + jpiv[kk] = itemp; + } + +/* Generate elementary reflector H(KK) using the column A(I:M,KK), */ +/* if the column has more than one element, otherwise */ +/* the elementary reflector would be an identity matrix, */ +/* and TAU(KK) = ZERO. */ + + if (i__ < *m) { + i__2 = *m - i__ + 1; + slarfg_(&i__2, &a[i__ + kk * a_dim1], &a[i__ + 1 + kk * a_dim1], & + c__1, &tau[kk]); + } else { + tau[kk] = 0.f; + } + +/* Check if TAU(KK) contains NaN, set INFO parameter */ +/* to the column number where NaN is found and return from */ +/* the routine. */ +/* NOTE: There is no need to check TAU(KK) for Inf, */ +/* since SLARFG cannot produce TAU(KK) or Householder vector */ +/* below the diagonal containing Inf. Only BETA on the diagonal, */ +/* returned by SLARFG can contain Inf, which requires */ +/* TAU(KK) to contain NaN. Therefore, this case of generating Inf */ +/* by SLARFG is covered by checking TAU(KK) for NaN. */ + + if (sisnan_(&tau[kk])) { + *k = kk - 1; + *info = kk; + +/* Set MAXC2NRMK and RELMAXC2NRMK to NaN. */ + + *maxc2nrmk = tau[kk]; + *relmaxc2nrmk = tau[kk]; + +/* Array TAU(KK:MINMNFACT) is not set and contains */ +/* undefined elements, except the first element TAU(KK) = NaN. */ + + return 0; + } + +/* Apply H(KK)**T to A(I:M,KK+1:N+NRHS) from the left. */ +/* ( If M >= N, then at KK = N there is no residual matrix, */ +/* i.e. no columns of A to update, only columns of B. */ +/* If M < N, then at KK = M-IOFFSET, I = M and we have a */ +/* one-row residual matrix in A and the elementary */ +/* reflector is a unit matrix, TAU(KK) = ZERO, i.e. no update */ +/* is needed for the residual matrix in A and the */ +/* right-hand-side-matrix in B. */ +/* Therefore, we update only if */ +/* KK < MINMNUPDT = f2cmin(M-IOFFSET, N+NRHS) */ +/* condition is satisfied, not only KK < N+NRHS ) */ + + if (kk < minmnupdt) { + aikk = a[i__ + kk * a_dim1]; + a[i__ + kk * a_dim1] = 1.f; + i__2 = *m - i__ + 1; + i__3 = *n + *nrhs - kk; + slarf_("Left", &i__2, &i__3, &a[i__ + kk * a_dim1], &c__1, &tau[ + kk], &a[i__ + (kk + 1) * a_dim1], lda, &work[1]); + a[i__ + kk * a_dim1] = aikk; + } + + if (kk < minmnfact) { + +/* Update the partial column 2-norms for the residual matrix, */ +/* only if the residual matrix A(I+1:M,KK+1:N) exists, i.e. */ +/* when KK < f2cmin(M-IOFFSET, N). */ + + i__2 = *n; + for (j = kk + 1; j <= i__2; ++j) { + if (vn1[j] != 0.f) { + +/* NOTE: The following lines follow from the analysis in */ +/* Lapack Working Note 176. */ + +/* Computing 2nd power */ + r__2 = (r__1 = a[i__ + j * a_dim1], abs(r__1)) / vn1[j]; + temp = 1.f - r__2 * r__2; + temp = f2cmax(temp,0.f); +/* Computing 2nd power */ + r__1 = vn1[j] / vn2[j]; + temp2 = temp * (r__1 * r__1); + if (temp2 <= tol3z) { + +/* Compute the column 2-norm for the partial */ +/* column A(I+1:M,J) by explicitly computing it, */ +/* and store it in both partial 2-norm vector VN1 */ +/* and exact column 2-norm vector VN2. */ + + i__3 = *m - i__; + vn1[j] = snrm2_(&i__3, &a[i__ + 1 + j * a_dim1], & + c__1); + vn2[j] = vn1[j]; + + } else { + +/* Update the column 2-norm for the partial */ +/* column A(I+1:M,J) by removing one */ +/* element A(I,J) and store it in partial */ +/* 2-norm vector VN1. */ + + vn1[j] *= sqrt(temp); + + } + } + } + + } + +/* End factorization loop */ + + } + +/* If we reached this point, all colunms have been factorized, */ +/* i.e. no condition was triggered to exit the routine. */ +/* Set the number of factorized columns. */ + + *k = *kmax; + +/* We reached the end of the loop, i.e. all KMAX columns were */ +/* factorized, we need to set MAXC2NRMK and RELMAXC2NRMK before */ +/* we return. */ + + if (*k < minmnfact) { + + i__1 = *n - *k; + jmaxc2nrm = *k + isamax_(&i__1, &vn1[*k + 1], &c__1); + *maxc2nrmk = vn1[jmaxc2nrm]; + + if (*k == 0) { + *relmaxc2nrmk = 1.f; + } else { + *relmaxc2nrmk = *maxc2nrmk / *maxc2nrm; + } + + } else { + *maxc2nrmk = 0.f; + *relmaxc2nrmk = 0.f; + } + +/* We reached the end of the loop, i.e. all KMAX columns were */ +/* factorized, set TAUs corresponding to the columns that were */ +/* not factorized to ZERO, i.e. TAU(K+1:MINMNFACT) set to ZERO. */ + + i__1 = minmnfact; + for (j = *k + 1; j <= i__1; ++j) { + tau[j] = 0.f; + } + + return 0; + +/* End of SLAQP2RK */ + +} /* slaqp2rk_ */ + diff --git a/lapack-netlib/SRC/slaqp3rk.c b/lapack-netlib/SRC/slaqp3rk.c new file mode 100644 index 000000000..e3632538b --- /dev/null +++ b/lapack-netlib/SRC/slaqp3rk.c @@ -0,0 +1,1109 @@ +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +#if defined(_WIN64) +typedef long long BLASLONG; +typedef unsigned long long BLASULONG; +#else +typedef long BLASLONG; +typedef unsigned long BLASULONG; +#endif + +#ifdef LAPACK_ILP64 +typedef BLASLONG blasint; +#if defined(_WIN64) +#define blasabs(x) llabs(x) +#else +#define blasabs(x) labs(x) +#endif +#else +typedef int blasint; +#define blasabs(x) abs(x) +#endif + +typedef blasint integer; + +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +#ifdef _MSC_VER +static inline _Fcomplex Cf(complex *z) {_Fcomplex zz={z->r , z->i}; return zz;} +static inline _Dcomplex Cd(doublecomplex *z) {_Dcomplex zz={z->r , z->i};return zz;} +static inline _Fcomplex * _pCf(complex *z) {return (_Fcomplex*)z;} +static inline _Dcomplex * _pCd(doublecomplex *z) {return (_Dcomplex*)z;} +#else +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#endif +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#ifdef _MSC_VER +#define c_div(c, a, b) {Cf(c)._Val[0] = (Cf(a)._Val[0]/Cf(b)._Val[0]); Cf(c)._Val[1]=(Cf(a)._Val[1]/Cf(b)._Val[1]);} +#define z_div(c, a, b) {Cd(c)._Val[0] = (Cd(a)._Val[0]/Cd(b)._Val[0]); Cd(c)._Val[1]=(Cd(a)._Val[1]/Cd(b)._Val[1]);} +#else +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#endif +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conjf(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimagf(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) {ceil(w)} +#define myhuge_(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +#ifdef _MSC_VER +static _Fcomplex cpow_ui(complex x, integer n) { + complex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x.r = 1/x.r, x.i=1/x.i; + for(u = n; ; ) { + if(u & 01) pow.r *= x.r, pow.i *= x.i; + if(u >>= 1) x.r *= x.r, x.i *= x.i; + else break; + } + } + _Fcomplex p={pow.r, pow.i}; + return p; +} +#else +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +#endif +#ifdef _MSC_VER +static _Dcomplex zpow_ui(_Dcomplex x, integer n) { + _Dcomplex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x._Val[0] = 1/x._Val[0], x._Val[1] =1/x._Val[1]; + for(u = n; ; ) { + if(u & 01) pow._Val[0] *= x._Val[0], pow._Val[1] *= x._Val[1]; + if(u >>= 1) x._Val[0] *= x._Val[0], x._Val[1] *= x._Val[1]; + else break; + } + } + _Dcomplex p = {pow._Val[0], pow._Val[1]}; + return p; +} +#else +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +#endif +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; +#ifdef _MSC_VER + _Fcomplex zdotc = {0.0, 0.0}; + if (incx == 1 && incy == 1) { + for (i=0;i 0 && *kb < *m - *ioffset) { + i__1 = *m - if__; + sgemm_("No transpose", "Transpose", &i__1, nrhs, kb, & + c_b7, &a[if__ + 1 + a_dim1], lda, &f[*n + 1 + + f_dim1], ldf, &c_b8, &a[if__ + 1 + (*n + 1) * + a_dim1], lda); + } + +/* There is no need to recompute the 2-norm of the */ +/* difficult columns, since we stop the factorization. */ + +/* Array TAU(KF+1:MINMNFACT) is not set and contains */ +/* undefined elements. */ + +/* Return from the routine. */ + + return 0; + } + +/* Quick return, if the submatrix A(I:M,K:N) is */ +/* a zero matrix. We need to check it only if the column index */ +/* (same as row index) is larger than 1, since the condition */ +/* for the whole original matrix A_orig is checked in the main */ +/* routine. */ + + if (*maxc2nrmk == 0.f) { + + *done = TRUE_; + +/* Set KB, the number of factorized partial columns */ +/* that are non-zero in each step in the block, */ +/* i.e. the rank of the factor R. */ +/* Set IF, the number of processed rows in the block, which */ +/* is the same as the number of processed rows in */ +/* the original whole matrix A_orig. */ + + *kb = k - 1; + if__ = i__ - 1; + *relmaxc2nrmk = 0.f; + +/* There is no need to apply the block reflector to the */ +/* residual of the matrix A stored in A(KB+1:M,KB+1:N), */ +/* since the submatrix is zero and we stop the computation. */ +/* But, we need to apply the block reflector to the residual */ +/* right hand sides stored in A(KB+1:M,N+1:N+NRHS), if the */ +/* residual right hand sides exist. This occurs */ +/* when ( NRHS != 0 AND KB <= (M-IOFFSET) ): */ + +/* A(I+1:M,N+1:N+NRHS) := A(I+1:M,N+1:N+NRHS) - */ +/* A(I+1:M,1:KB) * F(N+1:N+NRHS,1:KB)**T. */ + + if (*nrhs > 0 && *kb < *m - *ioffset) { + i__1 = *m - if__; + sgemm_("No transpose", "Transpose", &i__1, nrhs, kb, & + c_b7, &a[if__ + 1 + a_dim1], lda, &f[*n + 1 + + f_dim1], ldf, &c_b8, &a[if__ + 1 + (*n + 1) * + a_dim1], lda); + } + +/* There is no need to recompute the 2-norm of the */ +/* difficult columns, since we stop the factorization. */ + +/* Set TAUs corresponding to the columns that were not */ +/* factorized to ZERO, i.e. set TAU(KB+1:MINMNFACT) = ZERO, */ +/* which is equivalent to seting TAU(K:MINMNFACT) = ZERO. */ + + i__1 = minmnfact; + for (j = k; j <= i__1; ++j) { + tau[j] = 0.f; + } + +/* Return from the routine. */ + + return 0; + + } + +/* ============================================================ */ + +/* Check if the submatrix A(I:M,K:N) contains Inf, */ +/* set INFO parameter to the column number, where */ +/* the first Inf is found plus N, and continue */ +/* the computation. */ +/* We need to check the condition only if the */ +/* column index (same as row index) of the original whole */ +/* matrix is larger than 1, since the condition for whole */ +/* original matrix is checked in the main routine. */ + + if (*info == 0 && *maxc2nrmk > myhugeval) { + *info = *n + k - 1 + kp; + } + +/* ============================================================ */ + +/* Test for the second and third tolerance stopping criteria. */ +/* NOTE: There is no need to test for ABSTOL.GE.ZERO, since */ +/* MAXC2NRMK is non-negative. Similarly, there is no need */ +/* to test for RELTOL.GE.ZERO, since RELMAXC2NRMK is */ +/* non-negative. */ +/* We need to check the condition only if the */ +/* column index (same as row index) of the original whole */ +/* matrix is larger than 1, since the condition for whole */ +/* original matrix is checked in the main routine. */ + + *relmaxc2nrmk = *maxc2nrmk / *maxc2nrm; + + if (*maxc2nrmk <= *abstol || *relmaxc2nrmk <= *reltol) { + + *done = TRUE_; + +/* Set KB, the number of factorized partial columns */ +/* that are non-zero in each step in the block, */ +/* i.e. the rank of the factor R. */ +/* Set IF, the number of processed rows in the block, which */ +/* is the same as the number of processed rows in */ +/* the original whole matrix A_orig; */ + + *kb = k - 1; + if__ = i__ - 1; + +/* Apply the block reflector to the residual of the */ +/* matrix A and the residual of the right hand sides B, if */ +/* the residual matrix and and/or the residual of the right */ +/* hand sides exist, i.e. if the submatrix */ +/* A(I+1:M,KB+1:N+NRHS) exists. This occurs when */ +/* KB < MINMNUPDT = f2cmin( M-IOFFSET, N+NRHS ): */ + +/* A(IF+1:M,K+1:N+NRHS) := A(IF+1:M,KB+1:N+NRHS) - */ +/* A(IF+1:M,1:KB) * F(KB+1:N+NRHS,1:KB)**T. */ + + if (*kb < minmnupdt) { + i__1 = *m - if__; + i__2 = *n + *nrhs - *kb; + sgemm_("No transpose", "Transpose", &i__1, &i__2, kb, & + c_b7, &a[if__ + 1 + a_dim1], lda, &f[*kb + 1 + + f_dim1], ldf, &c_b8, &a[if__ + 1 + (*kb + 1) * + a_dim1], lda); + } + +/* There is no need to recompute the 2-norm of the */ +/* difficult columns, since we stop the factorization. */ + +/* Set TAUs corresponding to the columns that were not */ +/* factorized to ZERO, i.e. set TAU(KB+1:MINMNFACT) = ZERO, */ +/* which is equivalent to seting TAU(K:MINMNFACT) = ZERO. */ + + i__1 = minmnfact; + for (j = k; j <= i__1; ++j) { + tau[j] = 0.f; + } + +/* Return from the routine. */ + + return 0; + + } + +/* ============================================================ */ + +/* End ELSE of IF(I.EQ.1) */ + + } + +/* =============================================================== */ + +/* If the pivot column is not the first column of the */ +/* subblock A(1:M,K:N): */ +/* 1) swap the K-th column and the KP-th pivot column */ +/* in A(1:M,1:N); */ +/* 2) swap the K-th row and the KP-th row in F(1:N,1:K-1) */ +/* 3) copy the K-th element into the KP-th element of the partial */ +/* and exact 2-norm vectors VN1 and VN2. (Swap is not needed */ +/* for VN1 and VN2 since we use the element with the index */ +/* larger than K in the next loop step.) */ +/* 4) Save the pivot interchange with the indices relative to the */ +/* the original matrix A_orig, not the block A(1:M,1:N). */ + + if (kp != k) { + sswap_(m, &a[kp * a_dim1 + 1], &c__1, &a[k * a_dim1 + 1], &c__1); + i__1 = k - 1; + sswap_(&i__1, &f[kp + f_dim1], ldf, &f[k + f_dim1], ldf); + vn1[kp] = vn1[k]; + vn2[kp] = vn2[k]; + itemp = jpiv[kp]; + jpiv[kp] = jpiv[k]; + jpiv[k] = itemp; + } + +/* Apply previous Householder reflectors to column K: */ +/* A(I:M,K) := A(I:M,K) - A(I:M,1:K-1)*F(K,1:K-1)**T. */ + + if (k > 1) { + i__1 = *m - i__ + 1; + i__2 = k - 1; + sgemv_("No transpose", &i__1, &i__2, &c_b7, &a[i__ + a_dim1], lda, + &f[k + f_dim1], ldf, &c_b8, &a[i__ + k * a_dim1], &c__1); + } + +/* Generate elementary reflector H(k) using the column A(I:M,K). */ + + if (i__ < *m) { + i__1 = *m - i__ + 1; + slarfg_(&i__1, &a[i__ + k * a_dim1], &a[i__ + 1 + k * a_dim1], & + c__1, &tau[k]); + } else { + tau[k] = 0.f; + } + +/* Check if TAU(K) contains NaN, set INFO parameter */ +/* to the column number where NaN is found and return from */ +/* the routine. */ +/* NOTE: There is no need to check TAU(K) for Inf, */ +/* since SLARFG cannot produce TAU(K) or Householder vector */ +/* below the diagonal containing Inf. Only BETA on the diagonal, */ +/* returned by SLARFG can contain Inf, which requires */ +/* TAU(K) to contain NaN. Therefore, this case of generating Inf */ +/* by SLARFG is covered by checking TAU(K) for NaN. */ + + if (sisnan_(&tau[k])) { + + *done = TRUE_; + +/* Set KB, the number of factorized partial columns */ +/* that are non-zero in each step in the block, */ +/* i.e. the rank of the factor R. */ +/* Set IF, the number of processed rows in the block, which */ +/* is the same as the number of processed rows in */ +/* the original whole matrix A_orig. */ + + *kb = k - 1; + if__ = i__ - 1; + *info = k; + +/* Set MAXC2NRMK and RELMAXC2NRMK to NaN. */ + + *maxc2nrmk = tau[k]; + *relmaxc2nrmk = tau[k]; + +/* There is no need to apply the block reflector to the */ +/* residual of the matrix A stored in A(KB+1:M,KB+1:N), */ +/* since the submatrix contains NaN and we stop */ +/* the computation. */ +/* But, we need to apply the block reflector to the residual */ +/* right hand sides stored in A(KB+1:M,N+1:N+NRHS), if the */ +/* residual right hand sides exist. This occurs */ +/* when ( NRHS != 0 AND KB <= (M-IOFFSET) ): */ + +/* A(I+1:M,N+1:N+NRHS) := A(I+1:M,N+1:N+NRHS) - */ +/* A(I+1:M,1:KB) * F(N+1:N+NRHS,1:KB)**T. */ + + if (*nrhs > 0 && *kb < *m - *ioffset) { + i__1 = *m - if__; + sgemm_("No transpose", "Transpose", &i__1, nrhs, kb, &c_b7, & + a[if__ + 1 + a_dim1], lda, &f[*n + 1 + f_dim1], ldf, & + c_b8, &a[if__ + 1 + (*n + 1) * a_dim1], lda); + } + +/* There is no need to recompute the 2-norm of the */ +/* difficult columns, since we stop the factorization. */ + +/* Array TAU(KF+1:MINMNFACT) is not set and contains */ +/* undefined elements. */ + +/* Return from the routine. */ + + return 0; + } + +/* =============================================================== */ + + aik = a[i__ + k * a_dim1]; + a[i__ + k * a_dim1] = 1.f; + +/* =============================================================== */ + +/* Compute the current K-th column of F: */ +/* 1) F(K+1:N,K) := tau(K) * A(I:M,K+1:N)**T * A(I:M,K). */ + + if (k < *n + *nrhs) { + i__1 = *m - i__ + 1; + i__2 = *n + *nrhs - k; + sgemv_("Transpose", &i__1, &i__2, &tau[k], &a[i__ + (k + 1) * + a_dim1], lda, &a[i__ + k * a_dim1], &c__1, &c_b30, &f[k + + 1 + k * f_dim1], &c__1); + } + +/* 2) Zero out elements above and on the diagonal of the */ +/* column K in matrix F, i.e elements F(1:K,K). */ + + i__1 = k; + for (j = 1; j <= i__1; ++j) { + f[j + k * f_dim1] = 0.f; + } + +/* 3) Incremental updating of the K-th column of F: */ +/* F(1:N,K) := F(1:N,K) - tau(K) * F(1:N,1:K-1) * A(I:M,1:K-1)**T */ +/* * A(I:M,K). */ + + if (k > 1) { + i__1 = *m - i__ + 1; + i__2 = k - 1; + r__1 = -tau[k]; + sgemv_("Transpose", &i__1, &i__2, &r__1, &a[i__ + a_dim1], lda, & + a[i__ + k * a_dim1], &c__1, &c_b30, &auxv[1], &c__1); + + i__1 = *n + *nrhs; + i__2 = k - 1; + sgemv_("No transpose", &i__1, &i__2, &c_b8, &f[f_dim1 + 1], ldf, & + auxv[1], &c__1, &c_b8, &f[k * f_dim1 + 1], &c__1); + } + +/* =============================================================== */ + +/* Update the current I-th row of A: */ +/* A(I,K+1:N+NRHS) := A(I,K+1:N+NRHS) */ +/* - A(I,1:K)*F(K+1:N+NRHS,1:K)**T. */ + + if (k < *n + *nrhs) { + i__1 = *n + *nrhs - k; + sgemv_("No transpose", &i__1, &k, &c_b7, &f[k + 1 + f_dim1], ldf, + &a[i__ + a_dim1], lda, &c_b8, &a[i__ + (k + 1) * a_dim1], + lda); + } + + a[i__ + k * a_dim1] = aik; + +/* Update the partial column 2-norms for the residual matrix, */ +/* only if the residual matrix A(I+1:M,K+1:N) exists, i.e. */ +/* when K < MINMNFACT = f2cmin( M-IOFFSET, N ). */ + + if (k < minmnfact) { + + i__1 = *n; + for (j = k + 1; j <= i__1; ++j) { + if (vn1[j] != 0.f) { + +/* NOTE: The following lines follow from the analysis in */ +/* Lapack Working Note 176. */ + + temp = (r__1 = a[i__ + j * a_dim1], abs(r__1)) / vn1[j]; +/* Computing MAX */ + r__1 = 0.f, r__2 = (temp + 1.f) * (1.f - temp); + temp = f2cmax(r__1,r__2); +/* Computing 2nd power */ + r__1 = vn1[j] / vn2[j]; + temp2 = temp * (r__1 * r__1); + if (temp2 <= tol3z) { + +/* At J-index, we have a difficult column for the */ +/* update of the 2-norm. Save the index of the previous */ +/* difficult column in IWORK(J-1). */ +/* NOTE: ILSTCC > 1, threfore we can use IWORK only */ +/* with N-1 elements, where the elements are */ +/* shifted by 1 to the left. */ + + iwork[j - 1] = lsticc; + +/* Set the index of the last difficult column LSTICC. */ + + lsticc = j; + + } else { + vn1[j] *= sqrt(temp); + } + } + } + + } + +/* End of while loop. */ + + } + +/* Now, afler the loop: */ +/* Set KB, the number of factorized columns in the block; */ +/* Set IF, the number of processed rows in the block, which */ +/* is the same as the number of processed rows in */ +/* the original whole matrix A_orig, IF = IOFFSET + KB. */ + + *kb = k; + if__ = i__; + +/* Apply the block reflector to the residual of the matrix A */ +/* and the residual of the right hand sides B, if the residual */ +/* matrix and and/or the residual of the right hand sides */ +/* exist, i.e. if the submatrix A(I+1:M,KB+1:N+NRHS) exists. */ +/* This occurs when KB < MINMNUPDT = f2cmin( M-IOFFSET, N+NRHS ): */ + +/* A(IF+1:M,K+1:N+NRHS) := A(IF+1:M,KB+1:N+NRHS) - */ +/* A(IF+1:M,1:KB) * F(KB+1:N+NRHS,1:KB)**T. */ + + if (*kb < minmnupdt) { + i__1 = *m - if__; + i__2 = *n + *nrhs - *kb; + sgemm_("No transpose", "Transpose", &i__1, &i__2, kb, &c_b7, &a[if__ + + 1 + a_dim1], lda, &f[*kb + 1 + f_dim1], ldf, &c_b8, &a[if__ + + 1 + (*kb + 1) * a_dim1], lda); + } + +/* Recompute the 2-norm of the difficult columns. */ +/* Loop over the index of the difficult columns from the largest */ +/* to the smallest index. */ + + while(lsticc > 0) { + +/* LSTICC is the index of the last difficult column is greater */ +/* than 1. */ +/* ITEMP is the index of the previous difficult column. */ + + itemp = iwork[lsticc - 1]; + +/* Compute the 2-norm explicilty for the last difficult column and */ +/* save it in the partial and exact 2-norm vectors VN1 and VN2. */ + +/* NOTE: The computation of VN1( LSTICC ) relies on the fact that */ +/* SNRM2 does not fail on vectors with norm below the value of */ +/* SQRT(SLAMCH('S')) */ + + i__1 = *m - if__; + vn1[lsticc] = snrm2_(&i__1, &a[if__ + 1 + lsticc * a_dim1], &c__1); + vn2[lsticc] = vn1[lsticc]; + +/* Downdate the index of the last difficult column to */ +/* the index of the previous difficult column. */ + + lsticc = itemp; + + } + + return 0; + +/* End of SLAQP3RK */ + +} /* slaqp3rk_ */ + diff --git a/lapack-netlib/SRC/zgeqp3rk.c b/lapack-netlib/SRC/zgeqp3rk.c new file mode 100644 index 000000000..0c8b41c2d --- /dev/null +++ b/lapack-netlib/SRC/zgeqp3rk.c @@ -0,0 +1,1074 @@ +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +#if defined(_WIN64) +typedef long long BLASLONG; +typedef unsigned long long BLASULONG; +#else +typedef long BLASLONG; +typedef unsigned long BLASULONG; +#endif + +#ifdef LAPACK_ILP64 +typedef BLASLONG blasint; +#if defined(_WIN64) +#define blasabs(x) llabs(x) +#else +#define blasabs(x) labs(x) +#endif +#else +typedef int blasint; +#define blasabs(x) abs(x) +#endif + +typedef blasint integer; + +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +#ifdef _MSC_VER +static inline _Fcomplex Cf(complex *z) {_Fcomplex zz={z->r , z->i}; return zz;} +static inline _Dcomplex Cd(doublecomplex *z) {_Dcomplex zz={z->r , z->i};return zz;} +static inline _Fcomplex * _pCf(complex *z) {return (_Fcomplex*)z;} +static inline _Dcomplex * _pCd(doublecomplex *z) {return (_Dcomplex*)z;} +#else +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#endif +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#ifdef _MSC_VER +#define c_div(c, a, b) {Cf(c)._Val[0] = (Cf(a)._Val[0]/Cf(b)._Val[0]); Cf(c)._Val[1]=(Cf(a)._Val[1]/Cf(b)._Val[1]);} +#define z_div(c, a, b) {Cd(c)._Val[0] = (Cd(a)._Val[0]/Cd(b)._Val[0]); Cd(c)._Val[1]=(Cd(a)._Val[1]/Cd(b)._Val[1]);} +#else +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#endif +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conjf(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimagf(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) {ceil(w)} +#define myhuge_(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +#ifdef _MSC_VER +static _Fcomplex cpow_ui(complex x, integer n) { + complex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x.r = 1/x.r, x.i=1/x.i; + for(u = n; ; ) { + if(u & 01) pow.r *= x.r, pow.i *= x.i; + if(u >>= 1) x.r *= x.r, x.i *= x.i; + else break; + } + } + _Fcomplex p={pow.r, pow.i}; + return p; +} +#else +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +#endif +#ifdef _MSC_VER +static _Dcomplex zpow_ui(_Dcomplex x, integer n) { + _Dcomplex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x._Val[0] = 1/x._Val[0], x._Val[1] =1/x._Val[1]; + for(u = n; ; ) { + if(u & 01) pow._Val[0] *= x._Val[0], pow._Val[1] *= x._Val[1]; + if(u >>= 1) x._Val[0] *= x._Val[0], x._Val[1] *= x._Val[1]; + else break; + } + } + _Dcomplex p = {pow._Val[0], pow._Val[1]}; + return p; +} +#else +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +#endif +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; +#ifdef _MSC_VER + _Fcomplex zdotc = {0.0, 0.0}; + if (incx == 1 && incy == 1) { + for (i=0;i myhugeval) { + +/* Check if the matrix A contains +Inf or -Inf, set INFO parameter */ +/* to the column number, where the first +/-Inf is found plus N, */ +/* and continue the computation. */ + + *info = *n + kp1; + + } + +/* ================================================================== */ + +/* Quick return if possible for the case when the first */ +/* stopping criterion is satisfied, i.e. KMAX = 0. */ + + if (*kmax == 0) { + *k = 0; + *maxc2nrmk = maxc2nrm; + *relmaxc2nrmk = 1.; + i__1 = minmn; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + tau[i__2].r = 0., tau[i__2].i = 0.; + } + z__1.r = (doublereal) lwkopt, z__1.i = 0.; + work[1].r = z__1.r, work[1].i = z__1.i; + return 0; + } + +/* ================================================================== */ + + eps = dlamch_("Epsilon"); + +/* Adjust ABSTOL */ + + if (*abstol >= 0.) { + safmin = dlamch_("Safe minimum"); +/* Computing MAX */ + d__1 = *abstol, d__2 = safmin * 2.; + *abstol = f2cmax(d__1,d__2); + } + +/* Adjust RELTOL */ + + if (*reltol >= 0.) { + *reltol = f2cmax(*reltol,eps); + } + +/* =================================================================== */ + +/* JMAX is the maximum index of the column to be factorized, */ +/* which is also limited by the first stopping criterion KMAX. */ + + jmax = f2cmin(*kmax,minmn); + +/* =================================================================== */ + +/* Quick return if possible for the case when the second or third */ +/* stopping criterion for the whole original matrix is satified, */ +/* i.e. MAXC2NRM <= ABSTOL or RELMAXC2NRM <= RELTOL */ +/* (which is ONE <= RELTOL). */ + + if (maxc2nrm <= *abstol || 1. <= *reltol) { + + *k = 0; + *maxc2nrmk = maxc2nrm; + *relmaxc2nrmk = 1.; + + i__1 = minmn; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + tau[i__2].r = 0., tau[i__2].i = 0.; + } + + z__1.r = (doublereal) lwkopt, z__1.i = 0.; + work[1].r = z__1.r, work[1].i = z__1.i; + return 0; + } + +/* ================================================================== */ +/* Factorize columns */ +/* ================================================================== */ + +/* Determine the block size. */ + + nbmin = 2; + nx = 0; + + if (nb > 1 && nb < minmn) { + +/* Determine when to cross over from blocked to unblocked code. */ +/* (for N less than NX, unblocked code should be used). */ + +/* Computing MAX */ + i__1 = 0, i__2 = ilaenv_(&c__3, "ZGEQP3RK", " ", m, n, &c_n1, &c_n1, ( + ftnlen)8, (ftnlen)1); + nx = f2cmax(i__1,i__2); + + if (nx < minmn) { + +/* Determine if workspace is large enough for blocked code. */ + + if (*lwork < lwkopt) { + +/* Not enough workspace to use optimal block size that */ +/* is currently stored in NB. */ +/* Reduce NB and determine the minimum value of NB. */ + + nb = (*lwork - (*n << 1)) / (*n + 1); +/* Computing MAX */ + i__1 = 2, i__2 = ilaenv_(&c__2, "ZGEQP3RK", " ", m, n, &c_n1, + &c_n1, (ftnlen)8, (ftnlen)1); + nbmin = f2cmax(i__1,i__2); + + } + } + } + +/* ================================================================== */ + +/* DONE is the boolean flag to rerpresent the case when the */ +/* factorization completed in the block factorization routine, */ +/* before the end of the block. */ + + done = FALSE_; + +/* J is the column index. */ + + j = 1; + +/* (1) Use blocked code initially. */ + +/* JMAXB is the maximum column index of the block, when the */ +/* blocked code is used, is also limited by the first stopping */ +/* criterion KMAX. */ + +/* Computing MIN */ + i__1 = *kmax, i__2 = minmn - nx; + jmaxb = f2cmin(i__1,i__2); + + if (nb >= nbmin && nb < jmax && jmaxb > 0) { + +/* Loop over the column blocks of the matrix A(1:M,1:JMAXB). Here: */ +/* J is the column index of a column block; */ +/* JB is the column block size to pass to block factorization */ +/* routine in a loop step; */ +/* JBF is the number of columns that were actually factorized */ +/* that was returned by the block factorization routine */ +/* in a loop step, JBF <= JB; */ +/* N_SUB is the number of columns in the submatrix; */ +/* IOFFSET is the number of rows that should not be factorized. */ + + while(j <= jmaxb) { + +/* Computing MIN */ + i__1 = nb, i__2 = jmaxb - j + 1; + jb = f2cmin(i__1,i__2); + n_sub__ = *n - j + 1; + ioffset = j - 1; + +/* Factorize JB columns among the columns A(J:N). */ + + i__1 = *n + *nrhs - j + 1; + zlaqp3rk_(m, &n_sub__, nrhs, &ioffset, &jb, abstol, reltol, &kp1, + &maxc2nrm, &a[j * a_dim1 + 1], lda, &done, &jbf, + maxc2nrmk, relmaxc2nrmk, &jpiv[j], &tau[j], &rwork[j], & + rwork[*n + j], &work[1], &work[jb + 1], &i__1, &iwork[1], + &iinfo); + +/* Set INFO on the first occurence of Inf. */ + + if (iinfo > n_sub__ && *info == 0) { + *info = (ioffset << 1) + iinfo; + } + + if (done) { + +/* Either the submatrix is zero before the end of the */ +/* column block, or ABSTOL or RELTOL criterion is */ +/* satisfied before the end of the column block, we can */ +/* return from the routine. Perform the following before */ +/* returning: */ +/* a) Set the number of factorized columns K, */ +/* K = IOFFSET + JBF from the last call of blocked */ +/* routine. */ +/* NOTE: 1) MAXC2NRMK and RELMAXC2NRMK are returned */ +/* by the block factorization routine; */ +/* 2) The remaining TAUs are set to ZERO by the */ +/* block factorization routine. */ + + *k = ioffset + jbf; + +/* Set INFO on the first occurrence of NaN, NaN takes */ +/* prcedence over Inf. */ + + if (iinfo <= n_sub__ && iinfo > 0) { + *info = ioffset + iinfo; + } + +/* Return from the routine. */ + + z__1.r = (doublereal) lwkopt, z__1.i = 0.; + work[1].r = z__1.r, work[1].i = z__1.i; + + return 0; + + } + + j += jbf; + + } + + } + +/* Use unblocked code to factor the last or only block. */ +/* J = JMAX+1 means we factorized the maximum possible number of */ +/* columns, that is in ELSE clause we need to compute */ +/* the MAXC2NORM and RELMAXC2NORM to return after we processed */ +/* the blocks. */ + + if (j <= jmax) { + +/* N_SUB is the number of columns in the submatrix; */ +/* IOFFSET is the number of rows that should not be factorized. */ + + n_sub__ = *n - j + 1; + ioffset = j - 1; + + i__1 = jmax - j + 1; + zlaqp2rk_(m, &n_sub__, nrhs, &ioffset, &i__1, abstol, reltol, &kp1, & + maxc2nrm, &a[j * a_dim1 + 1], lda, &kf, maxc2nrmk, + relmaxc2nrmk, &jpiv[j], &tau[j], &rwork[j], &rwork[*n + j], & + work[1], &iinfo); + +/* ABSTOL or RELTOL criterion is satisfied when the number of */ +/* the factorized columns KF is smaller then the number */ +/* of columns JMAX-J+1 supplied to be factorized by the */ +/* unblocked routine, we can return from */ +/* the routine. Perform the following before returning: */ +/* a) Set the number of factorized columns K, */ +/* b) MAXC2NRMK and RELMAXC2NRMK are returned by the */ +/* unblocked factorization routine above. */ + + *k = j - 1 + kf; + +/* Set INFO on the first exception occurence. */ + +/* Set INFO on the first exception occurence of Inf or NaN, */ +/* (NaN takes precedence over Inf). */ + + if (iinfo > n_sub__ && *info == 0) { + *info = (ioffset << 1) + iinfo; + } else if (iinfo <= n_sub__ && iinfo > 0) { + *info = ioffset + iinfo; + } + + } else { + +/* Compute the return values for blocked code. */ + +/* Set the number of factorized columns if the unblocked routine */ +/* was not called. */ + + *k = jmax; + +/* If there exits a residual matrix after the blocked code: */ +/* 1) compute the values of MAXC2NRMK, RELMAXC2NRMK of the */ +/* residual matrix, otherwise set them to ZERO; */ +/* 2) Set TAU(K+1:MINMN) to ZERO. */ + + if (*k < minmn) { + i__1 = *n - *k; + jmaxc2nrm = *k + idamax_(&i__1, &rwork[*k + 1], &c__1); + *maxc2nrmk = rwork[jmaxc2nrm]; + if (*k == 0) { + *relmaxc2nrmk = 1.; + } else { + *relmaxc2nrmk = *maxc2nrmk / maxc2nrm; + } + + i__1 = minmn; + for (j = *k + 1; j <= i__1; ++j) { + i__2 = j; + tau[i__2].r = 0., tau[i__2].i = 0.; + } + + } else { + *maxc2nrmk = 0.; + *relmaxc2nrmk = 0.; + + } + +/* END IF( J.LE.JMAX ) THEN */ + + } + + z__1.r = (doublereal) lwkopt, z__1.i = 0.; + work[1].r = z__1.r, work[1].i = z__1.i; + + return 0; + +/* End of ZGEQP3RK */ + +} /* zgeqp3rk_ */ + diff --git a/lapack-netlib/SRC/zlaqp2rk.c b/lapack-netlib/SRC/zlaqp2rk.c new file mode 100644 index 000000000..0d38e71fb --- /dev/null +++ b/lapack-netlib/SRC/zlaqp2rk.c @@ -0,0 +1,947 @@ +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +#if defined(_WIN64) +typedef long long BLASLONG; +typedef unsigned long long BLASULONG; +#else +typedef long BLASLONG; +typedef unsigned long BLASULONG; +#endif + +#ifdef LAPACK_ILP64 +typedef BLASLONG blasint; +#if defined(_WIN64) +#define blasabs(x) llabs(x) +#else +#define blasabs(x) labs(x) +#endif +#else +typedef int blasint; +#define blasabs(x) abs(x) +#endif + +typedef blasint integer; + +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +#ifdef _MSC_VER +static inline _Fcomplex Cf(complex *z) {_Fcomplex zz={z->r , z->i}; return zz;} +static inline _Dcomplex Cd(doublecomplex *z) {_Dcomplex zz={z->r , z->i};return zz;} +static inline _Fcomplex * _pCf(complex *z) {return (_Fcomplex*)z;} +static inline _Dcomplex * _pCd(doublecomplex *z) {return (_Dcomplex*)z;} +#else +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#endif +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#ifdef _MSC_VER +#define c_div(c, a, b) {Cf(c)._Val[0] = (Cf(a)._Val[0]/Cf(b)._Val[0]); Cf(c)._Val[1]=(Cf(a)._Val[1]/Cf(b)._Val[1]);} +#define z_div(c, a, b) {Cd(c)._Val[0] = (Cd(a)._Val[0]/Cd(b)._Val[0]); Cd(c)._Val[1]=(Cd(a)._Val[1]/Cd(b)._Val[1]);} +#else +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#endif +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conjf(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimagf(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) {ceil(w)} +#define myhuge_(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +#ifdef _MSC_VER +static _Fcomplex cpow_ui(complex x, integer n) { + complex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x.r = 1/x.r, x.i=1/x.i; + for(u = n; ; ) { + if(u & 01) pow.r *= x.r, pow.i *= x.i; + if(u >>= 1) x.r *= x.r, x.i *= x.i; + else break; + } + } + _Fcomplex p={pow.r, pow.i}; + return p; +} +#else +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +#endif +#ifdef _MSC_VER +static _Dcomplex zpow_ui(_Dcomplex x, integer n) { + _Dcomplex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x._Val[0] = 1/x._Val[0], x._Val[1] =1/x._Val[1]; + for(u = n; ; ) { + if(u & 01) pow._Val[0] *= x._Val[0], pow._Val[1] *= x._Val[1]; + if(u >>= 1) x._Val[0] *= x._Val[0], x._Val[1] *= x._Val[1]; + else break; + } + } + _Dcomplex p = {pow._Val[0], pow._Val[1]}; + return p; +} +#else +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +#endif +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; +#ifdef _MSC_VER + _Fcomplex zdotc = {0.0, 0.0}; + if (incx == 1 && incy == 1) { + for (i=0;i myhugeval) { + *info = *n + kk - 1 + kp; + } + +/* ============================================================ */ + +/* Test for the second and third stopping criteria. */ +/* NOTE: There is no need to test for ABSTOL >= ZERO, since */ +/* MAXC2NRMK is non-negative. Similarly, there is no need */ +/* to test for RELTOL >= ZERO, since RELMAXC2NRMK is */ +/* non-negative. */ +/* We need to check the condition only if the */ +/* column index (same as row index) of the original whole */ +/* matrix is larger than 1, since the condition for whole */ +/* original matrix is checked in the main routine. */ + *relmaxc2nrmk = *maxc2nrmk / *maxc2nrm; + + if (*maxc2nrmk <= *abstol || *relmaxc2nrmk <= *reltol) { + +/* Set K, the number of factorized columns. */ + + *k = kk - 1; + +/* Set TAUs corresponding to the columns that were not */ +/* factorized to ZERO, i.e. set TAU(KK:MINMNFACT) to CZERO. */ + + i__2 = minmnfact; + for (j = kk; j <= i__2; ++j) { + i__3 = j; + tau[i__3].r = 0., tau[i__3].i = 0.; + } + +/* Return from the routine. */ + + return 0; + + } + +/* ============================================================ */ + +/* End ELSE of IF(I.EQ.1) */ + + } + +/* =============================================================== */ + +/* If the pivot column is not the first column of the */ +/* subblock A(1:M,KK:N): */ +/* 1) swap the KK-th column and the KP-th pivot column */ +/* in A(1:M,1:N); */ +/* 2) copy the KK-th element into the KP-th element of the partial */ +/* and exact 2-norm vectors VN1 and VN2. ( Swap is not needed */ +/* for VN1 and VN2 since we use the element with the index */ +/* larger than KK in the next loop step.) */ +/* 3) Save the pivot interchange with the indices relative to the */ +/* the original matrix A, not the block A(1:M,1:N). */ + + if (kp != kk) { + zswap_(m, &a[kp * a_dim1 + 1], &c__1, &a[kk * a_dim1 + 1], &c__1); + vn1[kp] = vn1[kk]; + vn2[kp] = vn2[kk]; + itemp = jpiv[kp]; + jpiv[kp] = jpiv[kk]; + jpiv[kk] = itemp; + } + +/* Generate elementary reflector H(KK) using the column A(I:M,KK), */ +/* if the column has more than one element, otherwise */ +/* the elementary reflector would be an identity matrix, */ +/* and TAU(KK) = CZERO. */ + + if (i__ < *m) { + i__2 = *m - i__ + 1; + zlarfg_(&i__2, &a[i__ + kk * a_dim1], &a[i__ + 1 + kk * a_dim1], & + c__1, &tau[kk]); + } else { + i__2 = kk; + tau[i__2].r = 0., tau[i__2].i = 0.; + } + +/* Check if TAU(KK) contains NaN, set INFO parameter */ +/* to the column number where NaN is found and return from */ +/* the routine. */ +/* NOTE: There is no need to check TAU(KK) for Inf, */ +/* since ZLARFG cannot produce TAU(KK) or Householder vector */ +/* below the diagonal containing Inf. Only BETA on the diagonal, */ +/* returned by ZLARFG can contain Inf, which requires */ +/* TAU(KK) to contain NaN. Therefore, this case of generating Inf */ +/* by ZLARFG is covered by checking TAU(KK) for NaN. */ + + i__2 = kk; + d__1 = tau[i__2].r; + if (disnan_(&d__1)) { + i__2 = kk; + taunan = tau[i__2].r; + } else /* if(complicated condition) */ { + d__1 = d_imag(&tau[kk]); + if (disnan_(&d__1)) { + taunan = d_imag(&tau[kk]); + } else { + taunan = 0.; + } + } + + if (disnan_(&taunan)) { + *k = kk - 1; + *info = kk; + +/* Set MAXC2NRMK and RELMAXC2NRMK to NaN. */ + + *maxc2nrmk = taunan; + *relmaxc2nrmk = taunan; + +/* Array TAU(KK:MINMNFACT) is not set and contains */ +/* undefined elements, except the first element TAU(KK) = NaN. */ + + return 0; + } + +/* Apply H(KK)**H to A(I:M,KK+1:N+NRHS) from the left. */ +/* ( If M >= N, then at KK = N there is no residual matrix, */ +/* i.e. no columns of A to update, only columns of B. */ +/* If M < N, then at KK = M-IOFFSET, I = M and we have a */ +/* one-row residual matrix in A and the elementary */ +/* reflector is a unit matrix, TAU(KK) = CZERO, i.e. no update */ +/* is needed for the residual matrix in A and the */ +/* right-hand-side-matrix in B. */ +/* Therefore, we update only if */ +/* KK < MINMNUPDT = f2cmin(M-IOFFSET, N+NRHS) */ +/* condition is satisfied, not only KK < N+NRHS ) */ + + if (kk < minmnupdt) { + i__2 = i__ + kk * a_dim1; + aikk.r = a[i__2].r, aikk.i = a[i__2].i; + i__2 = i__ + kk * a_dim1; + a[i__2].r = 1., a[i__2].i = 0.; + i__2 = *m - i__ + 1; + i__3 = *n + *nrhs - kk; + d_cnjg(&z__1, &tau[kk]); + zlarf_("Left", &i__2, &i__3, &a[i__ + kk * a_dim1], &c__1, &z__1, + &a[i__ + (kk + 1) * a_dim1], lda, &work[1]); + i__2 = i__ + kk * a_dim1; + a[i__2].r = aikk.r, a[i__2].i = aikk.i; + } + + if (kk < minmnfact) { + +/* Update the partial column 2-norms for the residual matrix, */ +/* only if the residual matrix A(I+1:M,KK+1:N) exists, i.e. */ +/* when KK < f2cmin(M-IOFFSET, N). */ + + i__2 = *n; + for (j = kk + 1; j <= i__2; ++j) { + if (vn1[j] != 0.) { + +/* NOTE: The following lines follow from the analysis in */ +/* Lapack Working Note 176. */ + +/* Computing 2nd power */ + d__1 = z_abs(&a[i__ + j * a_dim1]) / vn1[j]; + temp = 1. - d__1 * d__1; + temp = f2cmax(temp,0.); +/* Computing 2nd power */ + d__1 = vn1[j] / vn2[j]; + temp2 = temp * (d__1 * d__1); + if (temp2 <= tol3z) { + +/* Compute the column 2-norm for the partial */ +/* column A(I+1:M,J) by explicitly computing it, */ +/* and store it in both partial 2-norm vector VN1 */ +/* and exact column 2-norm vector VN2. */ + + i__3 = *m - i__; + vn1[j] = dznrm2_(&i__3, &a[i__ + 1 + j * a_dim1], & + c__1); + vn2[j] = vn1[j]; + + } else { + +/* Update the column 2-norm for the partial */ +/* column A(I+1:M,J) by removing one */ +/* element A(I,J) and store it in partial */ +/* 2-norm vector VN1. */ + + vn1[j] *= sqrt(temp); + + } + } + } + + } + +/* End factorization loop */ + + } + +/* If we reached this point, all colunms have been factorized, */ +/* i.e. no condition was triggered to exit the routine. */ +/* Set the number of factorized columns. */ + + *k = *kmax; + +/* We reached the end of the loop, i.e. all KMAX columns were */ +/* factorized, we need to set MAXC2NRMK and RELMAXC2NRMK before */ +/* we return. */ + + if (*k < minmnfact) { + + i__1 = *n - *k; + jmaxc2nrm = *k + idamax_(&i__1, &vn1[*k + 1], &c__1); + *maxc2nrmk = vn1[jmaxc2nrm]; + + if (*k == 0) { + *relmaxc2nrmk = 1.; + } else { + *relmaxc2nrmk = *maxc2nrmk / *maxc2nrm; + } + + } else { + *maxc2nrmk = 0.; + *relmaxc2nrmk = 0.; + } + +/* We reached the end of the loop, i.e. all KMAX columns were */ +/* factorized, set TAUs corresponding to the columns that were */ +/* not factorized to ZERO, i.e. TAU(K+1:MINMNFACT) set to CZERO. */ + + i__1 = minmnfact; + for (j = *k + 1; j <= i__1; ++j) { + i__2 = j; + tau[i__2].r = 0., tau[i__2].i = 0.; + } + + return 0; + +/* End of ZLAQP2RK */ + +} /* zlaqp2rk_ */ + diff --git a/lapack-netlib/SRC/zlaqp3rk.c b/lapack-netlib/SRC/zlaqp3rk.c new file mode 100644 index 000000000..cb44e4d34 --- /dev/null +++ b/lapack-netlib/SRC/zlaqp3rk.c @@ -0,0 +1,1157 @@ +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +#if defined(_WIN64) +typedef long long BLASLONG; +typedef unsigned long long BLASULONG; +#else +typedef long BLASLONG; +typedef unsigned long BLASULONG; +#endif + +#ifdef LAPACK_ILP64 +typedef BLASLONG blasint; +#if defined(_WIN64) +#define blasabs(x) llabs(x) +#else +#define blasabs(x) labs(x) +#endif +#else +typedef int blasint; +#define blasabs(x) abs(x) +#endif + +typedef blasint integer; + +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +#ifdef _MSC_VER +static inline _Fcomplex Cf(complex *z) {_Fcomplex zz={z->r , z->i}; return zz;} +static inline _Dcomplex Cd(doublecomplex *z) {_Dcomplex zz={z->r , z->i};return zz;} +static inline _Fcomplex * _pCf(complex *z) {return (_Fcomplex*)z;} +static inline _Dcomplex * _pCd(doublecomplex *z) {return (_Dcomplex*)z;} +#else +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#endif +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#ifdef _MSC_VER +#define c_div(c, a, b) {Cf(c)._Val[0] = (Cf(a)._Val[0]/Cf(b)._Val[0]); Cf(c)._Val[1]=(Cf(a)._Val[1]/Cf(b)._Val[1]);} +#define z_div(c, a, b) {Cd(c)._Val[0] = (Cd(a)._Val[0]/Cd(b)._Val[0]); Cd(c)._Val[1]=(Cd(a)._Val[1]/Cd(b)._Val[1]);} +#else +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#endif +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conjf(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimagf(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) {ceil(w)} +#define myhuge_(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +#ifdef _MSC_VER +static _Fcomplex cpow_ui(complex x, integer n) { + complex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x.r = 1/x.r, x.i=1/x.i; + for(u = n; ; ) { + if(u & 01) pow.r *= x.r, pow.i *= x.i; + if(u >>= 1) x.r *= x.r, x.i *= x.i; + else break; + } + } + _Fcomplex p={pow.r, pow.i}; + return p; +} +#else +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +#endif +#ifdef _MSC_VER +static _Dcomplex zpow_ui(_Dcomplex x, integer n) { + _Dcomplex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x._Val[0] = 1/x._Val[0], x._Val[1] =1/x._Val[1]; + for(u = n; ; ) { + if(u & 01) pow._Val[0] *= x._Val[0], pow._Val[1] *= x._Val[1]; + if(u >>= 1) x._Val[0] *= x._Val[0], x._Val[1] *= x._Val[1]; + else break; + } + } + _Dcomplex p = {pow._Val[0], pow._Val[1]}; + return p; +} +#else +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +#endif +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; +#ifdef _MSC_VER + _Fcomplex zdotc = {0.0, 0.0}; + if (incx == 1 && incy == 1) { + for (i=0;i 0 && *kb < *m - *ioffset) { + i__1 = *m - if__; + z__1.r = -1., z__1.i = 0.; + zgemm_("No transpose", "Conjugate transpose", &i__1, nrhs, + kb, &z__1, &a[if__ + 1 + a_dim1], lda, &f[*n + 1 + + f_dim1], ldf, &c_b2, &a[if__ + 1 + (*n + 1) * + a_dim1], lda); + } + +/* There is no need to recompute the 2-norm of the */ +/* difficult columns, since we stop the factorization. */ + +/* Array TAU(KF+1:MINMNFACT) is not set and contains */ +/* undefined elements. */ + +/* Return from the routine. */ + + return 0; + } + +/* Quick return, if the submatrix A(I:M,K:N) is */ +/* a zero matrix. We need to check it only if the column index */ +/* (same as row index) is larger than 1, since the condition */ +/* for the whole original matrix A_orig is checked in the main */ +/* routine. */ + + if (*maxc2nrmk == 0.) { + + *done = TRUE_; + +/* Set KB, the number of factorized partial columns */ +/* that are non-zero in each step in the block, */ +/* i.e. the rank of the factor R. */ +/* Set IF, the number of processed rows in the block, which */ +/* is the same as the number of processed rows in */ +/* the original whole matrix A_orig. */ + + *kb = k - 1; + if__ = i__ - 1; + *relmaxc2nrmk = 0.; + +/* There is no need to apply the block reflector to the */ +/* residual of the matrix A stored in A(KB+1:M,KB+1:N), */ +/* since the submatrix is zero and we stop the computation. */ +/* But, we need to apply the block reflector to the residual */ +/* right hand sides stored in A(KB+1:M,N+1:N+NRHS), if the */ +/* residual right hand sides exist. This occurs */ +/* when ( NRHS != 0 AND KB <= (M-IOFFSET) ): */ + +/* A(I+1:M,N+1:N+NRHS) := A(I+1:M,N+1:N+NRHS) - */ +/* A(I+1:M,1:KB) * F(N+1:N+NRHS,1:KB)**H. */ + + if (*nrhs > 0 && *kb < *m - *ioffset) { + i__1 = *m - if__; + z__1.r = -1., z__1.i = 0.; + zgemm_("No transpose", "Conjugate transpose", &i__1, nrhs, + kb, &z__1, &a[if__ + 1 + a_dim1], lda, &f[*n + 1 + + f_dim1], ldf, &c_b2, &a[if__ + 1 + (*n + 1) * + a_dim1], lda); + } + +/* There is no need to recompute the 2-norm of the */ +/* difficult columns, since we stop the factorization. */ + +/* Set TAUs corresponding to the columns that were not */ +/* factorized to ZERO, i.e. set TAU(KB+1:MINMNFACT) = CZERO, */ +/* which is equivalent to seting TAU(K:MINMNFACT) = CZERO. */ + + i__1 = minmnfact; + for (j = k; j <= i__1; ++j) { + i__2 = j; + tau[i__2].r = 0., tau[i__2].i = 0.; + } + +/* Return from the routine. */ + + return 0; + + } + +/* ============================================================ */ + +/* Check if the submatrix A(I:M,K:N) contains Inf, */ +/* set INFO parameter to the column number, where */ +/* the first Inf is found plus N, and continue */ +/* the computation. */ +/* We need to check the condition only if the */ +/* column index (same as row index) of the original whole */ +/* matrix is larger than 1, since the condition for whole */ +/* original matrix is checked in the main routine. */ + + if (*info == 0 && *maxc2nrmk > myhugeval) { + *info = *n + k - 1 + kp; + } + +/* ============================================================ */ + +/* Test for the second and third tolerance stopping criteria. */ +/* NOTE: There is no need to test for ABSTOL.GE.ZERO, since */ +/* MAXC2NRMK is non-negative. Similarly, there is no need */ +/* to test for RELTOL.GE.ZERO, since RELMAXC2NRMK is */ +/* non-negative. */ +/* We need to check the condition only if the */ +/* column index (same as row index) of the original whole */ +/* matrix is larger than 1, since the condition for whole */ +/* original matrix is checked in the main routine. */ + + *relmaxc2nrmk = *maxc2nrmk / *maxc2nrm; + + if (*maxc2nrmk <= *abstol || *relmaxc2nrmk <= *reltol) { + + *done = TRUE_; + +/* Set KB, the number of factorized partial columns */ +/* that are non-zero in each step in the block, */ +/* i.e. the rank of the factor R. */ +/* Set IF, the number of processed rows in the block, which */ +/* is the same as the number of processed rows in */ +/* the original whole matrix A_orig; */ + + *kb = k - 1; + if__ = i__ - 1; + +/* Apply the block reflector to the residual of the */ +/* matrix A and the residual of the right hand sides B, if */ +/* the residual matrix and and/or the residual of the right */ +/* hand sides exist, i.e. if the submatrix */ +/* A(I+1:M,KB+1:N+NRHS) exists. This occurs when */ +/* KB < MINMNUPDT = f2cmin( M-IOFFSET, N+NRHS ): */ + +/* A(IF+1:M,K+1:N+NRHS) := A(IF+1:M,KB+1:N+NRHS) - */ +/* A(IF+1:M,1:KB) * F(KB+1:N+NRHS,1:KB)**H. */ + + if (*kb < minmnupdt) { + i__1 = *m - if__; + i__2 = *n + *nrhs - *kb; + z__1.r = -1., z__1.i = 0.; + zgemm_("No transpose", "Conjugate transpose", &i__1, & + i__2, kb, &z__1, &a[if__ + 1 + a_dim1], lda, &f[* + kb + 1 + f_dim1], ldf, &c_b2, &a[if__ + 1 + (*kb + + 1) * a_dim1], lda); + } + +/* There is no need to recompute the 2-norm of the */ +/* difficult columns, since we stop the factorization. */ + +/* Set TAUs corresponding to the columns that were not */ +/* factorized to ZERO, i.e. set TAU(KB+1:MINMNFACT) = CZERO, */ +/* which is equivalent to seting TAU(K:MINMNFACT) = CZERO. */ + + i__1 = minmnfact; + for (j = k; j <= i__1; ++j) { + i__2 = j; + tau[i__2].r = 0., tau[i__2].i = 0.; + } + +/* Return from the routine. */ + + return 0; + + } + +/* ============================================================ */ + +/* End ELSE of IF(I.EQ.1) */ + + } + +/* =============================================================== */ + +/* If the pivot column is not the first column of the */ +/* subblock A(1:M,K:N): */ +/* 1) swap the K-th column and the KP-th pivot column */ +/* in A(1:M,1:N); */ +/* 2) swap the K-th row and the KP-th row in F(1:N,1:K-1) */ +/* 3) copy the K-th element into the KP-th element of the partial */ +/* and exact 2-norm vectors VN1 and VN2. (Swap is not needed */ +/* for VN1 and VN2 since we use the element with the index */ +/* larger than K in the next loop step.) */ +/* 4) Save the pivot interchange with the indices relative to the */ +/* the original matrix A_orig, not the block A(1:M,1:N). */ + + if (kp != k) { + zswap_(m, &a[kp * a_dim1 + 1], &c__1, &a[k * a_dim1 + 1], &c__1); + i__1 = k - 1; + zswap_(&i__1, &f[kp + f_dim1], ldf, &f[k + f_dim1], ldf); + vn1[kp] = vn1[k]; + vn2[kp] = vn2[k]; + itemp = jpiv[kp]; + jpiv[kp] = jpiv[k]; + jpiv[k] = itemp; + } + +/* Apply previous Householder reflectors to column K: */ +/* A(I:M,K) := A(I:M,K) - A(I:M,1:K-1)*F(K,1:K-1)**H. */ + + if (k > 1) { + i__1 = k - 1; + for (j = 1; j <= i__1; ++j) { + i__2 = k + j * f_dim1; + d_cnjg(&z__1, &f[k + j * f_dim1]); + f[i__2].r = z__1.r, f[i__2].i = z__1.i; + } + i__1 = *m - i__ + 1; + i__2 = k - 1; + z__1.r = -1., z__1.i = 0.; + zgemv_("No transpose", &i__1, &i__2, &z__1, &a[i__ + a_dim1], lda, + &f[k + f_dim1], ldf, &c_b2, &a[i__ + k * a_dim1], &c__1); + i__1 = k - 1; + for (j = 1; j <= i__1; ++j) { + i__2 = k + j * f_dim1; + d_cnjg(&z__1, &f[k + j * f_dim1]); + f[i__2].r = z__1.r, f[i__2].i = z__1.i; + } + } + +/* Generate elementary reflector H(k) using the column A(I:M,K). */ + + if (i__ < *m) { + i__1 = *m - i__ + 1; + zlarfg_(&i__1, &a[i__ + k * a_dim1], &a[i__ + 1 + k * a_dim1], & + c__1, &tau[k]); + } else { + i__1 = k; + tau[i__1].r = 0., tau[i__1].i = 0.; + } + +/* Check if TAU(K) contains NaN, set INFO parameter */ +/* to the column number where NaN is found and return from */ +/* the routine. */ +/* NOTE: There is no need to check TAU(K) for Inf, */ +/* since ZLARFG cannot produce TAU(KK) or Householder vector */ +/* below the diagonal containing Inf. Only BETA on the diagonal, */ +/* returned by ZLARFG can contain Inf, which requires */ +/* TAU(K) to contain NaN. Therefore, this case of generating Inf */ +/* by ZLARFG is covered by checking TAU(K) for NaN. */ + + i__1 = k; + d__1 = tau[i__1].r; + if (disnan_(&d__1)) { + i__1 = k; + taunan = tau[i__1].r; + } else /* if(complicated condition) */ { + d__1 = d_imag(&tau[k]); + if (disnan_(&d__1)) { + taunan = d_imag(&tau[k]); + } else { + taunan = 0.; + } + } + + if (disnan_(&taunan)) { + + *done = TRUE_; + +/* Set KB, the number of factorized partial columns */ +/* that are non-zero in each step in the block, */ +/* i.e. the rank of the factor R. */ +/* Set IF, the number of processed rows in the block, which */ +/* is the same as the number of processed rows in */ +/* the original whole matrix A_orig. */ + + *kb = k - 1; + if__ = i__ - 1; + *info = k; + +/* Set MAXC2NRMK and RELMAXC2NRMK to NaN. */ + + *maxc2nrmk = taunan; + *relmaxc2nrmk = taunan; + +/* There is no need to apply the block reflector to the */ +/* residual of the matrix A stored in A(KB+1:M,KB+1:N), */ +/* since the submatrix contains NaN and we stop */ +/* the computation. */ +/* But, we need to apply the block reflector to the residual */ +/* right hand sides stored in A(KB+1:M,N+1:N+NRHS), if the */ +/* residual right hand sides exist. This occurs */ +/* when ( NRHS != 0 AND KB <= (M-IOFFSET) ): */ + +/* A(I+1:M,N+1:N+NRHS) := A(I+1:M,N+1:N+NRHS) - */ +/* A(I+1:M,1:KB) * F(N+1:N+NRHS,1:KB)**H. */ + + if (*nrhs > 0 && *kb < *m - *ioffset) { + i__1 = *m - if__; + z__1.r = -1., z__1.i = 0.; + zgemm_("No transpose", "Conjugate transpose", &i__1, nrhs, kb, + &z__1, &a[if__ + 1 + a_dim1], lda, &f[*n + 1 + + f_dim1], ldf, &c_b2, &a[if__ + 1 + (*n + 1) * a_dim1], + lda); + } + +/* There is no need to recompute the 2-norm of the */ +/* difficult columns, since we stop the factorization. */ + +/* Array TAU(KF+1:MINMNFACT) is not set and contains */ +/* undefined elements. */ + +/* Return from the routine. */ + + return 0; + } + +/* =============================================================== */ + + i__1 = i__ + k * a_dim1; + aik.r = a[i__1].r, aik.i = a[i__1].i; + i__1 = i__ + k * a_dim1; + a[i__1].r = 1., a[i__1].i = 0.; + +/* =============================================================== */ + +/* Compute the current K-th column of F: */ +/* 1) F(K+1:N,K) := tau(K) * A(I:M,K+1:N)**H * A(I:M,K). */ + + if (k < *n + *nrhs) { + i__1 = *m - i__ + 1; + i__2 = *n + *nrhs - k; + zgemv_("Conjugate transpose", &i__1, &i__2, &tau[k], &a[i__ + (k + + 1) * a_dim1], lda, &a[i__ + k * a_dim1], &c__1, &c_b1, & + f[k + 1 + k * f_dim1], &c__1); + } + +/* 2) Zero out elements above and on the diagonal of the */ +/* column K in matrix F, i.e elements F(1:K,K). */ + + i__1 = k; + for (j = 1; j <= i__1; ++j) { + i__2 = j + k * f_dim1; + f[i__2].r = 0., f[i__2].i = 0.; + } + +/* 3) Incremental updating of the K-th column of F: */ +/* F(1:N,K) := F(1:N,K) - tau(K) * F(1:N,1:K-1) * A(I:M,1:K-1)**H */ +/* * A(I:M,K). */ + + if (k > 1) { + i__1 = *m - i__ + 1; + i__2 = k - 1; + i__3 = k; + z__1.r = -tau[i__3].r, z__1.i = -tau[i__3].i; + zgemv_("Conjugate Transpose", &i__1, &i__2, &z__1, &a[i__ + + a_dim1], lda, &a[i__ + k * a_dim1], &c__1, &c_b1, &auxv[1] + , &c__1); + + i__1 = *n + *nrhs; + i__2 = k - 1; + zgemv_("No transpose", &i__1, &i__2, &c_b2, &f[f_dim1 + 1], ldf, & + auxv[1], &c__1, &c_b2, &f[k * f_dim1 + 1], &c__1); + } + +/* =============================================================== */ + +/* Update the current I-th row of A: */ +/* A(I,K+1:N+NRHS) := A(I,K+1:N+NRHS) */ +/* - A(I,1:K)*F(K+1:N+NRHS,1:K)**H. */ + + if (k < *n + *nrhs) { + i__1 = *n + *nrhs - k; + z__1.r = -1., z__1.i = 0.; + zgemm_("No transpose", "Conjugate transpose", &c__1, &i__1, &k, & + z__1, &a[i__ + a_dim1], lda, &f[k + 1 + f_dim1], ldf, & + c_b2, &a[i__ + (k + 1) * a_dim1], lda); + } + + i__1 = i__ + k * a_dim1; + a[i__1].r = aik.r, a[i__1].i = aik.i; + +/* Update the partial column 2-norms for the residual matrix, */ +/* only if the residual matrix A(I+1:M,K+1:N) exists, i.e. */ +/* when K < MINMNFACT = f2cmin( M-IOFFSET, N ). */ + + if (k < minmnfact) { + + i__1 = *n; + for (j = k + 1; j <= i__1; ++j) { + if (vn1[j] != 0.) { + +/* NOTE: The following lines follow from the analysis in */ +/* Lapack Working Note 176. */ + + temp = z_abs(&a[i__ + j * a_dim1]) / vn1[j]; +/* Computing MAX */ + d__1 = 0., d__2 = (temp + 1.) * (1. - temp); + temp = f2cmax(d__1,d__2); +/* Computing 2nd power */ + d__1 = vn1[j] / vn2[j]; + temp2 = temp * (d__1 * d__1); + if (temp2 <= tol3z) { + +/* At J-index, we have a difficult column for the */ +/* update of the 2-norm. Save the index of the previous */ +/* difficult column in IWORK(J-1). */ +/* NOTE: ILSTCC > 1, threfore we can use IWORK only */ +/* with N-1 elements, where the elements are */ +/* shifted by 1 to the left. */ + + iwork[j - 1] = lsticc; + +/* Set the index of the last difficult column LSTICC. */ + + lsticc = j; + + } else { + vn1[j] *= sqrt(temp); + } + } + } + + } + +/* End of while loop. */ + + } + +/* Now, afler the loop: */ +/* Set KB, the number of factorized columns in the block; */ +/* Set IF, the number of processed rows in the block, which */ +/* is the same as the number of processed rows in */ +/* the original whole matrix A_orig, IF = IOFFSET + KB. */ + + *kb = k; + if__ = i__; + +/* Apply the block reflector to the residual of the matrix A */ +/* and the residual of the right hand sides B, if the residual */ +/* matrix and and/or the residual of the right hand sides */ +/* exist, i.e. if the submatrix A(I+1:M,KB+1:N+NRHS) exists. */ +/* This occurs when KB < MINMNUPDT = f2cmin( M-IOFFSET, N+NRHS ): */ + +/* A(IF+1:M,K+1:N+NRHS) := A(IF+1:M,KB+1:N+NRHS) - */ +/* A(IF+1:M,1:KB) * F(KB+1:N+NRHS,1:KB)**H. */ + + if (*kb < minmnupdt) { + i__1 = *m - if__; + i__2 = *n + *nrhs - *kb; + z__1.r = -1., z__1.i = 0.; + zgemm_("No transpose", "Conjugate transpose", &i__1, &i__2, kb, &z__1, + &a[if__ + 1 + a_dim1], lda, &f[*kb + 1 + f_dim1], ldf, &c_b2, + &a[if__ + 1 + (*kb + 1) * a_dim1], lda); + } + +/* Recompute the 2-norm of the difficult columns. */ +/* Loop over the index of the difficult columns from the largest */ +/* to the smallest index. */ + + while(lsticc > 0) { + +/* LSTICC is the index of the last difficult column is greater */ +/* than 1. */ +/* ITEMP is the index of the previous difficult column. */ + + itemp = iwork[lsticc - 1]; + +/* Compute the 2-norm explicilty for the last difficult column and */ +/* save it in the partial and exact 2-norm vectors VN1 and VN2. */ + +/* NOTE: The computation of VN1( LSTICC ) relies on the fact that */ +/* DZNRM2 does not fail on vectors with norm below the value of */ +/* SQRT(DLAMCH('S')) */ + + i__1 = *m - if__; + vn1[lsticc] = dznrm2_(&i__1, &a[if__ + 1 + lsticc * a_dim1], &c__1); + vn2[lsticc] = vn1[lsticc]; + +/* Downdate the index of the last difficult column to */ +/* the index of the previous difficult column. */ + + lsticc = itemp; + + } + + return 0; + +/* End of ZLAQP3RK */ + +} /* zlaqp3rk_ */ + From 20a2a83f498ada982c431bd34da39181d2785ba1 Mon Sep 17 00:00:00 2001 From: Martin Kroeker Date: Wed, 15 Nov 2023 12:18:15 +0100 Subject: [PATCH 09/60] Implement truncated QR with pivoting (Reference-LAPACK PR 891) --- lapack-netlib/SRC/Makefile | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/lapack-netlib/SRC/Makefile b/lapack-netlib/SRC/Makefile index 448fbd8df..de2242701 100644 --- a/lapack-netlib/SRC/Makefile +++ b/lapack-netlib/SRC/Makefile @@ -136,7 +136,7 @@ SLASRC_O = \ sgebrd.o sgecon.o sgeequ.o sgees.o sgeesx.o sgeev.o sgeevx.o \ sgehd2.o sgehrd.o sgelq2.o sgelqf.o \ sgels.o sgelsd.o sgelss.o sgelsy.o sgeql2.o sgeqlf.o \ - sgeqp3.o sgeqr2.o sgeqr2p.o sgeqrf.o sgeqrfp.o sgerfs.o \ + sgeqp3.o sgeqp3rk.o sgeqr2.o sgeqr2p.o sgeqrf.o sgeqrfp.o sgerfs.o \ sgerq2.o sgerqf.o sgesc2.o sgesdd.o sgesv.o sgesvd.o sgesvdx.o sgesvx.o \ sgetc2.o sgetf2.o sgetri.o \ sggbak.o sggbal.o sgges.o sgges3.o sggesx.o \ @@ -151,7 +151,7 @@ SLASRC_O = \ slangb.o slange.o slangt.o slanhs.o slansb.o slansp.o \ slansy.o slantb.o slantp.o slantr.o slanv2.o \ slapll.o slapmt.o \ - slaqgb.o slaqge.o slaqp2.o slaqps.o slaqsb.o slaqsp.o slaqsy.o \ + slaqgb.o slaqge.o slaqp2.o slaqp2rk.o slaqp3rk.o slaqps.o slaqsb.o slaqsp.o slaqsy.o \ slaqr0.o slaqr1.o slaqr2.o slaqr3.o slaqr4.o slaqr5.o \ slaqtr.o slar1v.o slar2v.o ilaslr.o ilaslc.o \ slarf.o slarfb.o slarfb_gett.o slarfg.o slarfgp.o slarft.o slarfx.o slarfy.o slargv.o \ @@ -232,7 +232,7 @@ CLASRC_O = \ cgbtf2.o cgbtrf.o cgbtrs.o cgebak.o cgebal.o cgebd2.o cgebrd.o \ cgecon.o cgeequ.o cgees.o cgeesx.o cgeev.o cgeevx.o \ cgehd2.o cgehrd.o cgelq2.o cgelqf.o \ - cgels.o cgelsd.o cgelss.o cgelsy.o cgeql2.o cgeqlf.o cgeqp3.o \ + cgels.o cgelsd.o cgelss.o cgelsy.o cgeql2.o cgeqlf.o cgeqp3.o cgeqp3rk.o \ cgeqr2.o cgeqr2p.o cgeqrf.o cgeqrfp.o cgerfs.o \ cgerq2.o cgerqf.o cgesc2.o cgesdd.o cgesv.o cgesvd.o cgesvdx.o \ cgesvj.o cgejsv.o cgsvj0.o cgsvj1.o \ @@ -266,7 +266,7 @@ CLASRC_O = \ clanhb.o clanhe.o \ clanhp.o clanhs.o clanht.o clansb.o clansp.o clansy.o clantb.o \ clantp.o clantr.o clapll.o clapmt.o clarcm.o claqgb.o claqge.o \ - claqhb.o claqhe.o claqhp.o claqp2.o claqps.o claqsb.o \ + claqhb.o claqhe.o claqhp.o claqp2.o claqp2rk.o claqp3rk.o claqps.o claqsb.o \ claqr0.o claqr1.o claqr2.o claqr3.o claqr4.o claqr5.o \ claqsp.o claqsy.o clar1v.o clar2v.o ilaclr.o ilaclc.o \ claqz0.o claqz1.o claqz2.o claqz3.o \ @@ -345,7 +345,7 @@ DLASRC_O = \ dgebrd.o dgecon.o dgeequ.o dgees.o dgeesx.o dgeev.o dgeevx.o \ dgehd2.o dgehrd.o dgelq2.o dgelqf.o \ dgels.o dgelsd.o dgelss.o dgelsy.o dgeql2.o dgeqlf.o \ - dgeqp3.o dgeqr2.o dgeqr2p.o dgeqrf.o dgeqrfp.o dgerfs.o \ + dgeqp3.o dgeqp3rk.o dgeqr2.o dgeqr2p.o dgeqrf.o dgeqrfp.o dgerfs.o \ dgerq2.o dgerqf.o dgesc2.o dgesdd.o dgesv.o dgesvd.o dgesvdx.o dgesvx.o \ dgetc2.o dgetf2.o dgetrf.o dgetri.o \ dgetrs.o dggbak.o dggbal.o dgges.o dgges3.o dggesx.o \ @@ -360,7 +360,7 @@ DLASRC_O = \ dlangb.o dlange.o dlangt.o dlanhs.o dlansb.o dlansp.o \ dlansy.o dlantb.o dlantp.o dlantr.o dlanv2.o \ dlapll.o dlapmt.o \ - dlaqgb.o dlaqge.o dlaqp2.o dlaqps.o dlaqsb.o dlaqsp.o dlaqsy.o \ + dlaqgb.o dlaqge.o dlaqp2.o dlaqp2rk.o dlaqp3rk.o dlaqps.o dlaqsb.o dlaqsp.o dlaqsy.o \ dlaqr0.o dlaqr1.o dlaqr2.o dlaqr3.o dlaqr4.o dlaqr5.o \ dlaqtr.o dlar1v.o dlar2v.o iladlr.o iladlc.o \ dlarf.o dlarfb.o dlarfb_gett.o dlarfg.o dlarfgp.o dlarft.o dlarfx.o dlarfy.o \ @@ -437,7 +437,7 @@ ZLASRC_O = \ zgbtf2.o zgbtrf.o zgbtrs.o zgebak.o zgebal.o zgebd2.o zgebrd.o \ zgecon.o zgeequ.o zgees.o zgeesx.o zgeev.o zgeevx.o \ zgehd2.o zgehrd.o zgelq2.o zgelqf.o \ - zgels.o zgelsd.o zgelss.o zgelsy.o zgeql2.o zgeqlf.o zgeqp3.o \ + zgels.o zgelsd.o zgelss.o zgelsy.o zgeql2.o zgeqlf.o zgeqp3.o zgeqp3rk.o \ zgeqr2.o zgeqr2p.o zgeqrf.o zgeqrfp.o zgerfs.o zgerq2.o zgerqf.o \ zgesc2.o zgesdd.o zgesv.o zgesvd.o zgesvdx.o \ zgesvj.o zgejsv.o zgsvj0.o zgsvj1.o \ @@ -473,7 +473,7 @@ ZLASRC_O = \ zlanhe.o \ zlanhp.o zlanhs.o zlanht.o zlansb.o zlansp.o zlansy.o zlantb.o \ zlantp.o zlantr.o zlapll.o zlapmt.o zlaqgb.o zlaqge.o \ - zlaqhb.o zlaqhe.o zlaqhp.o zlaqp2.o zlaqps.o zlaqsb.o \ + zlaqhb.o zlaqhe.o zlaqhp.o zlaqp2.o zlaqp2rk.o zlaqp3rk.o zlaqps.o zlaqsb.o \ zlaqr0.o zlaqr1.o zlaqr2.o zlaqr3.o zlaqr4.o zlaqr5.o \ zlaqsp.o zlaqsy.o zlar1v.o zlar2v.o ilazlr.o ilazlc.o \ zlaqz0.o zlaqz1.o zlaqz2.o zlaqz3.o \ From 8b2a9568905b6480b457fb8873a7dff7b116a9fc Mon Sep 17 00:00:00 2001 From: Martin Kroeker Date: Wed, 15 Nov 2023 14:20:12 +0100 Subject: [PATCH 10/60] Implement truncated QR with pivot (Reference-LAPACK PR 891) --- lapack-netlib/SRC/ilaenv.c | 83 +++++++++++++++++++++++++++++--------- 1 file changed, 63 insertions(+), 20 deletions(-) diff --git a/lapack-netlib/SRC/ilaenv.c b/lapack-netlib/SRC/ilaenv.c index c47224a0c..8f3b2db8e 100644 --- a/lapack-netlib/SRC/ilaenv.c +++ b/lapack-netlib/SRC/ilaenv.c @@ -191,7 +191,7 @@ typedef struct Namelist Namelist; #define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } #ifdef _MSC_VER #define c_div(c, a, b) {Cf(c)._Val[0] = (Cf(a)._Val[0]/Cf(b)._Val[0]); Cf(c)._Val[1]=(Cf(a)._Val[1]/Cf(b)._Val[1]);} -#define z_div(c, a, b) {Cd(c)._Val[0] = (Cd(a)._Val[0]/Cd(b)._Val[0]); Cd(c)._Val[1]=(Cd(a)._Val[1]/df(b)._Val[1]);} +#define z_div(c, a, b) {Cd(c)._Val[0] = (Cd(a)._Val[0]/Cd(b)._Val[0]); Cd(c)._Val[1]=(Cd(a)._Val[1]/Cd(b)._Val[1]);} #else #define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} #define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} @@ -252,11 +252,11 @@ static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; #define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} #define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} #define myexit_() break; -#define mycycle() continue; -#define myceiling(w) {ceil(w)} -#define myhuge(w) {HUGE_VAL} +#define mycycle_() continue; +#define myceiling_(w) {ceil(w)} +#define myhuge_(w) {HUGE_VAL} //#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} -#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) /* procedure parameter types for -A and -C++ */ @@ -509,12 +509,18 @@ static inline void zdotu_(doublecomplex *z, integer *n_, doublecomplex *x, integ +/* -- translated by f2c (version 20000121). + You must link the resulting object file with the libraries: + -lf2c -lm (in that order) +*/ + + /* Table of constant values */ static integer c__1 = 1; -static real c_b174 = 0.f; -static real c_b175 = 1.f; +static real c_b179 = 0.f; +static real c_b180 = 1.f; static integer c__0 = 0; /* > \brief \b ILAENV */ @@ -599,9 +605,9 @@ f"> */ /* > = 9: maximum size of the subproblems at the bottom of the */ /* > computation tree in the divide-and-conquer algorithm */ /* > (used by xGELSD and xGESDD) */ -/* > =10: ieee NaN arithmetic can be trusted not to trap */ +/* > =10: ieee infinity and NaN arithmetic can be trusted not to trap */ /* > =11: infinity arithmetic can be trusted not to trap */ -/* > 12 <= ISPEC <= 16: */ +/* > 12 <= ISPEC <= 17: */ /* > xHSEQR or related subroutines, */ /* > see IPARMQ for detailed explanation */ /* > \endverbatim */ @@ -652,9 +658,7 @@ f"> */ /* > \author Univ. of Colorado Denver */ /* > \author NAG Ltd. */ -/* > \date November 2019 */ - -/* > \ingroup OTHERauxiliary */ +/* > \ingroup ilaenv */ /* > \par Further Details: */ /* ===================== */ @@ -685,7 +689,7 @@ integer ilaenv_(integer *ispec, char *name__, char *opts, integer *n1, opts_len) { /* System generated locals */ - integer ret_val; + integer ret_val, i__1, i__2, i__3; /* Local variables */ logical twostage; @@ -702,10 +706,9 @@ integer ilaenv_(integer *ispec, char *name__, char *opts, integer *n1, integer *, integer *); -/* -- LAPACK auxiliary routine (version 3.9.0) -- */ +/* -- LAPACK auxiliary routine -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ -/* November 2019 */ /* ===================================================================== */ @@ -728,6 +731,7 @@ integer ilaenv_(integer *ispec, char *name__, char *opts, integer *n1, case 14: goto L160; case 15: goto L160; case 16: goto L160; + case 17: goto L160; } /* Invalid value for ISPEC */ @@ -908,6 +912,12 @@ L50: } else { nb = 64; } + } else if (s_cmp(subnam + 3, "QP3RK", (ftnlen)4, (ftnlen)5) == 0) { + if (sname) { + nb = 32; + } else { + nb = 32; + } } } else if (s_cmp(c2, "PO", (ftnlen)2, (ftnlen)2) == 0) { if (s_cmp(c3, "TRF", (ftnlen)3, (ftnlen)3) == 0) { @@ -1034,6 +1044,21 @@ L50: } else { nb = 64; } + } else if (s_cmp(c3, "SYL", (ftnlen)3, (ftnlen)3) == 0) { +/* The upper bound is to prevent overly aggressive scaling. */ + if (sname) { +/* Computing MIN */ +/* Computing MAX */ + i__2 = 48, i__3 = (f2cmin(*n1,*n2) << 4) / 100; + i__1 = f2cmax(i__2,i__3); + nb = f2cmin(i__1,240); + } else { +/* Computing MIN */ +/* Computing MAX */ + i__2 = 24, i__3 = (f2cmin(*n1,*n2) << 3) / 100; + i__1 = f2cmax(i__2,i__3); + nb = f2cmin(i__1,80); + } } } else if (s_cmp(c2, "LA", (ftnlen)2, (ftnlen)2) == 0) { if (s_cmp(c3, "UUM", (ftnlen)3, (ftnlen)3) == 0) { @@ -1042,6 +1067,12 @@ L50: } else { nb = 64; } + } else if (s_cmp(c3, "TRS", (ftnlen)3, (ftnlen)3) == 0) { + if (sname) { + nb = 32; + } else { + nb = 32; + } } } else if (sname && s_cmp(c2, "ST", (ftnlen)2, (ftnlen)2) == 0) { if (s_cmp(c3, "EBZ", (ftnlen)3, (ftnlen)3) == 0) { @@ -1093,6 +1124,12 @@ L60: } else { nbmin = 2; } + } else if (s_cmp(subnam + 3, "QP3RK", (ftnlen)4, (ftnlen)5) == 0) { + if (sname) { + nbmin = 2; + } else { + nbmin = 2; + } } } else if (s_cmp(c2, "SY", (ftnlen)2, (ftnlen)2) == 0) { if (s_cmp(c3, "TRF", (ftnlen)3, (ftnlen)3) == 0) { @@ -1184,6 +1221,12 @@ L70: } else { nx = 128; } + } else if (s_cmp(subnam + 3, "QP3RK", (ftnlen)4, (ftnlen)5) == 0) { + if (sname) { + nx = 128; + } else { + nx = 128; + } } } else if (s_cmp(c2, "SY", (ftnlen)2, (ftnlen)2) == 0) { if (sname && s_cmp(c3, "TRD", (ftnlen)3, (ftnlen)3) == 0) { @@ -1270,29 +1313,29 @@ L130: L140: -/* ISPEC = 10: ieee NaN arithmetic can be trusted not to trap */ +/* ISPEC = 10: ieee and infinity NaN arithmetic can be trusted not to trap */ /* ILAENV = 0 */ ret_val = 1; if (ret_val == 1) { - ret_val = ieeeck_(&c__1, &c_b174, &c_b175); + ret_val = ieeeck_(&c__1, &c_b179, &c_b180); } return ret_val; L150: -/* ISPEC = 11: infinity arithmetic can be trusted not to trap */ +/* ISPEC = 11: ieee infinity arithmetic can be trusted not to trap */ /* ILAENV = 0 */ ret_val = 1; if (ret_val == 1) { - ret_val = ieeeck_(&c__0, &c_b174, &c_b175); + ret_val = ieeeck_(&c__0, &c_b179, &c_b180); } return ret_val; L160: -/* 12 <= ISPEC <= 16: xHSEQR or related subroutines. */ +/* 12 <= ISPEC <= 17: xHSEQR or related subroutines. */ ret_val = iparmq_(ispec, name__, opts, n1, n2, n3, n4) ; From ee47e4e494629b29d39557d4415349566060a8e6 Mon Sep 17 00:00:00 2001 From: Martin Kroeker Date: Wed, 15 Nov 2023 15:21:32 +0100 Subject: [PATCH 11/60] run m1/llvm/cmake buid on all 4 cores --- .cirrus.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.cirrus.yml b/.cirrus.yml index 6c2baf8a0..b4c4870d0 100644 --- a/.cirrus.yml +++ b/.cirrus.yml @@ -29,7 +29,7 @@ task: - mkdir build - cd build - cmake -DTARGET=VORTEX -DCMAKE_C_COMPILER=clang -DBUILD_SHARED_LIBS=ON .. - - make + - make -j 4 task: name: AppleM1/GCC/MAKE/OPENMP From cc622f2406dc7f2ca47af27db5eb3bd57ab46ae0 Mon Sep 17 00:00:00 2001 From: Martin Kroeker Date: Wed, 15 Nov 2023 22:51:09 +0100 Subject: [PATCH 12/60] restore OpenBLAS-specific target_link_libraries --- lapack-netlib/TESTING/LIN/CMakeLists.txt | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/lapack-netlib/TESTING/LIN/CMakeLists.txt b/lapack-netlib/TESTING/LIN/CMakeLists.txt index e28818c76..143fd0597 100644 --- a/lapack-netlib/TESTING/LIN/CMakeLists.txt +++ b/lapack-netlib/TESTING/LIN/CMakeLists.txt @@ -239,7 +239,8 @@ set(ZLINTSTRFP zchkrfp.f zdrvrfp.f zdrvrf1.f zdrvrf2.f zdrvrf3.f zdrvrf4.f zerrr macro(add_lin_executable name) add_executable(${name} ${ARGN}) - target_link_libraries(${name} ${TMGLIB} ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES}) + target_link_libraries(${name} openblas${SUFFIX64_UNDERSCORE}) +#${TMGLIB} ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES}) endmacro() if(BUILD_SINGLE) From f8ad5344c210960fc399ca5b0ad8559ab5ca253e Mon Sep 17 00:00:00 2001 From: Bart Oldeman Date: Fri, 17 Nov 2023 23:49:34 +0000 Subject: [PATCH 13/60] Fix casum fallback kernel. This kernel is only used on Skylake+ if the kernel with AVX512 intrinsics can't be used, but used the variable x1 incorrectly in the tail end of the loop, as it is still at the initial value instead of where x points to. This caused 55 "other error"s in the LAPACK tests (https://github.com/OpenMathLib/OpenBLAS/issues/4282) This change makes casum.c as similar as possible as zasum.c, because zasum.c does this correctly. --- kernel/x86_64/casum.c | 24 ++++++++++++------------ 1 file changed, 12 insertions(+), 12 deletions(-) diff --git a/kernel/x86_64/casum.c b/kernel/x86_64/casum.c index e4d054311..28d78d279 100644 --- a/kernel/x86_64/casum.c +++ b/kernel/x86_64/casum.c @@ -9,12 +9,12 @@ #endif #ifndef HAVE_CASUM_KERNEL -static FLOAT casum_kernel(BLASLONG n, FLOAT *x1) +static FLOAT casum_kernel(BLASLONG n, FLOAT *x) { BLASLONG i=0; BLASLONG n_8 = n & -8; - FLOAT *x = x1; + FLOAT *x1 = x; FLOAT temp0, temp1, temp2, temp3; FLOAT temp4, temp5, temp6, temp7; FLOAT sum0 = 0.0; @@ -24,14 +24,14 @@ static FLOAT casum_kernel(BLASLONG n, FLOAT *x1) FLOAT sum4 = 0.0; while (i < n_8) { - temp0 = ABS_K(x[0]); - temp1 = ABS_K(x[1]); - temp2 = ABS_K(x[2]); - temp3 = ABS_K(x[3]); - temp4 = ABS_K(x[4]); - temp5 = ABS_K(x[5]); - temp6 = ABS_K(x[6]); - temp7 = ABS_K(x[7]); + temp0 = ABS_K(x1[0]); + temp1 = ABS_K(x1[1]); + temp2 = ABS_K(x1[2]); + temp3 = ABS_K(x1[3]); + temp4 = ABS_K(x1[4]); + temp5 = ABS_K(x1[5]); + temp6 = ABS_K(x1[6]); + temp7 = ABS_K(x1[7]); sum0 += temp0; sum1 += temp1; @@ -43,12 +43,12 @@ static FLOAT casum_kernel(BLASLONG n, FLOAT *x1) sum2 += temp6; sum3 += temp7; - x+=8; + x1+=8; i+=4; } while (i < n) { - sum4 += (ABS_K(x1[0]) + ABS_K(x1[1])); + sum4 += ABS_K(x1[0]) + ABS_K(x1[1]); x1 += 2; i++; } From 47b03fd4b4ce7bc51d5b56397e52e6da3c5f3f36 Mon Sep 17 00:00:00 2001 From: Martin Kroeker Date: Sat, 18 Nov 2023 23:45:02 +0100 Subject: [PATCH 14/60] Copy XCode15-specific workaround to Fortran flags to fix build of tests --- Makefile.system | 1 + 1 file changed, 1 insertion(+) diff --git a/Makefile.system b/Makefile.system index 1b84195e4..ff06e503c 100644 --- a/Makefile.system +++ b/Makefile.system @@ -407,6 +407,7 @@ XCVER = $(shell pkgutil --pkg-info=com.apple.pkg.CLTools_Executables |awk '/vers endif ifeq (x$(XCVER), x 15) CCOMMON_OPT += -Wl,-ld_classic +FCOMMON_OPT += -Wl,-ld_classic endif endif From 22aa401656032c70c4c0efb8d24bf1a63577c992 Mon Sep 17 00:00:00 2001 From: Martin Kroeker Date: Sun, 19 Nov 2023 00:04:31 +0100 Subject: [PATCH 15/60] Temporarily disable the AVX512 CASUM/ZASUM microkernels for any version of NVIDIA HPC (#4327) * Temporarily disable the C/ZASUM microkernels for any version of NVHPC --- kernel/x86_64/casum_microk_skylakex-2.c | 3 ++- kernel/x86_64/zasum_microk_skylakex-2.c | 3 ++- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/kernel/x86_64/casum_microk_skylakex-2.c b/kernel/x86_64/casum_microk_skylakex-2.c index d261962de..5d37fd541 100644 --- a/kernel/x86_64/casum_microk_skylakex-2.c +++ b/kernel/x86_64/casum_microk_skylakex-2.c @@ -4,7 +4,8 @@ #endif #if ((( defined(__GNUC__) && __GNUC__ > 6 && defined(__AVX512CD__)) || (defined(__clang__) && (__clang_major__ >= 9 &&__clang_major__ !=17)) || ( defined(__NVCOMPILER) && NVCOMPVERS >= 2309))) -#if (!(defined(__NVCOMPILER) && NVCOMPVERS < 2309)) +#if (!(defined(__NVCOMPILER) )) +//&& NVCOMPVERS < 2309)) #define HAVE_CASUM_KERNEL 1 diff --git a/kernel/x86_64/zasum_microk_skylakex-2.c b/kernel/x86_64/zasum_microk_skylakex-2.c index dddf03fe2..7260922e7 100644 --- a/kernel/x86_64/zasum_microk_skylakex-2.c +++ b/kernel/x86_64/zasum_microk_skylakex-2.c @@ -4,7 +4,8 @@ #endif #if ((( defined(__GNUC__) && __GNUC__ > 6 && defined(__AVX512CD__)) || (defined(__clang__) && ( __clang_major__ >= 9 && __clang_major__ != 17)) || (defined(__NVCOMPILER) && NVCOMPVERS >= 2309))) -#if (!(defined(__NVCOMPILER) && NVCOMPVERS < 2309)) +#if (!(defined(__NVCOMPILER) )) +//&& NVCOMPVERS < 2309)) #define HAVE_ZASUM_KERNEL 1 From 6b2651ece32365201793b02e78e198abd1f137ac Mon Sep 17 00:00:00 2001 From: Isuru Fernando Date: Sun, 19 Nov 2023 02:57:13 -0600 Subject: [PATCH 16/60] Fix building test_sbgemm --- test/Makefile | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/test/Makefile b/test/Makefile index 715842b4d..56acf1c5b 100644 --- a/test/Makefile +++ b/test/Makefile @@ -260,6 +260,7 @@ endif FLDFLAGS = $(FFLAGS:-fPIC=) $(LDFLAGS) +CLDFLAGS = $(CFLAGS) $(LDFLAGS) ifeq ($(USE_OPENMP), 1) @@ -331,7 +332,7 @@ endif ifeq ($(BUILD_BFLOAT16),1) test_sbgemm : compare_sgemm_sbgemm.c ../$(LIBNAME) - $(CC) $(CFLAGS) -o test_sbgemm compare_sgemm_sbgemm.c ../$(LIBNAME) $(EXTRALIB) $(CEXTRALIB) + $(CC) $(CLDFLAGS) -o test_sbgemm compare_sgemm_sbgemm.c ../$(LIBNAME) $(EXTRALIB) $(CEXTRALIB) endif ifeq ($(BUILD_COMPLEX),1) From c34e2cf380a757621f166e6ce8ea8755155158f2 Mon Sep 17 00:00:00 2001 From: Bart Oldeman Date: Sun, 19 Nov 2023 21:21:23 +0000 Subject: [PATCH 17/60] Use _mm_set1_epi{32,64x} to init mask in x86-64 [cz]asum for skylake kernels. This is the same method as used in [sd]asum. _mm_set1_epi64x was commented out for zasum, but has the advantage of avoiding possible undefined behaviour (using an uninitialized variable), optimized out by NVHPC and icx. The new code works fine with those compilers. For GCC 12.3 the generated code is identical; no matter what method you use, the compiler optimizes the code into a compile-time constant, there is no performance benefit using mm_cmpeq_epi8 since the corresponding instruction (VPCMPEQB) isn't actually generated! --- kernel/x86_64/casum_microk_skylakex-2.c | 10 ++++------ kernel/x86_64/zasum_microk_skylakex-2.c | 11 ++++------- 2 files changed, 8 insertions(+), 13 deletions(-) diff --git a/kernel/x86_64/casum_microk_skylakex-2.c b/kernel/x86_64/casum_microk_skylakex-2.c index 5d37fd541..10b70ff20 100644 --- a/kernel/x86_64/casum_microk_skylakex-2.c +++ b/kernel/x86_64/casum_microk_skylakex-2.c @@ -2,10 +2,9 @@ #ifdef __NVCOMPILER #define NVCOMPVERS ( __NVCOMPILER_MAJOR__ * 100 + __NVCOMPILER_MINOR__ ) #endif -#if ((( defined(__GNUC__) && __GNUC__ > 6 && defined(__AVX512CD__)) || (defined(__clang__) && (__clang_major__ >= 9 &&__clang_major__ !=17)) || ( defined(__NVCOMPILER) && NVCOMPVERS >= 2309))) +#if ((( defined(__GNUC__) && __GNUC__ > 6 && defined(__AVX512CD__)) || (defined(__clang__) && __clang_major__ >= 9)) || (defined(__NVCOMPILER) && NVCOMPVERS >= 2203)) -#if (!(defined(__NVCOMPILER) )) -//&& NVCOMPVERS < 2309)) +#if (!(defined(__NVCOMPILER) && NVCOMPVERS < 2203)) #define HAVE_CASUM_KERNEL 1 @@ -21,15 +20,14 @@ static FLOAT casum_kernel(BLASLONG n, FLOAT *x) if (n2 < 64) { __m128 accum_10, accum_11, accum_12, accum_13; - __m128 abs_mask1 = abs_mask1; + __m128 abs_mask1; accum_10 = _mm_setzero_ps(); accum_11 = _mm_setzero_ps(); accum_12 = _mm_setzero_ps(); accum_13 = _mm_setzero_ps(); - abs_mask1 = (__m128)_mm_cmpeq_epi8((__m128i) abs_mask1, (__m128i) abs_mask1); - abs_mask1 = (__m128)_mm_srli_epi32((__m128i) abs_mask1, 1); + abs_mask1 = (__m128)_mm_set1_epi32(0x7fffffff); _mm_prefetch(&x1[0], _MM_HINT_T0); diff --git a/kernel/x86_64/zasum_microk_skylakex-2.c b/kernel/x86_64/zasum_microk_skylakex-2.c index 7260922e7..f6bc8e37b 100644 --- a/kernel/x86_64/zasum_microk_skylakex-2.c +++ b/kernel/x86_64/zasum_microk_skylakex-2.c @@ -2,10 +2,9 @@ #ifdef __NVCOMPILER #define NVCOMPVERS ( __NVCOMPILER_MAJOR__ * 100 + __NVCOMPILER_MINOR__ ) #endif -#if ((( defined(__GNUC__) && __GNUC__ > 6 && defined(__AVX512CD__)) || (defined(__clang__) && ( __clang_major__ >= 9 && __clang_major__ != 17)) || (defined(__NVCOMPILER) && NVCOMPVERS >= 2309))) +#if ((( defined(__GNUC__) && __GNUC__ > 6 && defined(__AVX512CD__)) || (defined(__clang__) && __clang_major__ >= 9)) || (defined(__NVCOMPILER) && NVCOMPVERS >= 2203)) -#if (!(defined(__NVCOMPILER) )) -//&& NVCOMPVERS < 2309)) +#if (!(defined(__NVCOMPILER) && NVCOMPVERS < 2203)) #define HAVE_ZASUM_KERNEL 1 @@ -22,16 +21,14 @@ static FLOAT zasum_kernel(BLASLONG n, FLOAT *x) if (n2 < 32) { __m128d accum_10, accum_11, accum_12, accum_13; - __m128d abs_mask1 = abs_mask1; + __m128d abs_mask1; accum_10 = _mm_setzero_pd(); accum_11 = _mm_setzero_pd(); accum_12 = _mm_setzero_pd(); accum_13 = _mm_setzero_pd(); - // abs_mask1 = (__m128d)_mm_set1_epi64x(0x7fffffffffffffff); - abs_mask1 = (__m128d)_mm_cmpeq_epi8((__m128i) abs_mask1, (__m128i) abs_mask1); - abs_mask1 = (__m128d)_mm_srli_epi64((__m128i) abs_mask1, 1); + abs_mask1 = (__m128d)_mm_set1_epi64x(0x7fffffffffffffff); _mm_prefetch(&x1[0], _MM_HINT_T0); if (n2 >= 16){ From 54be8f4d67185c8bf4b7f0737504130e0fa53e83 Mon Sep 17 00:00:00 2001 From: Yuning Zhang Date: Mon, 20 Nov 2023 13:28:25 -0800 Subject: [PATCH 18/60] Update the list of default dynamic targets for x86_64 in the README to be consistent with the Makefile Signed-off-by: Yuning Zhang --- README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.md b/README.md index 3c4e38f18..aaadd0d9c 100644 --- a/README.md +++ b/README.md @@ -202,7 +202,7 @@ Please read `GotoBLAS_01Readme.txt` for older CPU models already supported by th OpenBLAS can be built for multiple targets with runtime detection of the target cpu by specifiying `DYNAMIC_ARCH=1` in Makefile.rule, on the gmake command line or as `-DDYNAMIC_ARCH=TRUE` in cmake. -For **x86_64**, the list of targets this activates contains Prescott, Core2, Nehalem, Barcelona, Sandybridge, Bulldozer, Piledriver, Steamroller, Excavator, Haswell, Zen, SkylakeX. For cpu generations not included in this list, the corresponding older model is used. If you also specify `DYNAMIC_OLDER=1`, specific support for Penryn, Dunnington, Opteron, Opteron/SSE3, Bobcat, Atom and Nano is added. Finally there is an option `DYNAMIC_LIST` that allows to specify an individual list of targets to include instead of the default. +For **x86_64**, the list of targets this activates contains Prescott, Core2, Nehalem, Barcelona, Sandybridge, Bulldozer, Piledriver, Steamroller, Excavator, Haswell, Zen, SkylakeX, Cooper Lake, Sapphire Rapids. For cpu generations not included in this list, the corresponding older model is used. If you also specify `DYNAMIC_OLDER=1`, specific support for Penryn, Dunnington, Opteron, Opteron/SSE3, Bobcat, Atom and Nano is added. Finally there is an option `DYNAMIC_LIST` that allows to specify an individual list of targets to include instead of the default. `DYNAMIC_ARCH` is also supported on **x86**, where it translates to Katmai, Coppermine, Northwood, Prescott, Banias, Core2, Penryn, Dunnington, Nehalem, Athlon, Opteron, Opteron_SSE3, Barcelona, Bobcat, Atom and Nano. From 47da601a2d456d1b85b8261e6b1d21a1c2c7e315 Mon Sep 17 00:00:00 2001 From: Rajalakshmi Srinivasaraghavan Date: Mon, 20 Nov 2023 17:24:22 -0600 Subject: [PATCH 19/60] POWER: Fixing Makefile error Recent commit d99aad8ee308600832da39105a6511275cfe32ad added extra `)`. This patch fixes the warning from Makefile. --- Makefile.power | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Makefile.power b/Makefile.power index aa1ca080a..3fa6d6faf 100644 --- a/Makefile.power +++ b/Makefile.power @@ -11,7 +11,7 @@ endif ifeq ($(CORE), POWER10) ifneq ($(C_COMPILER), PGI) -ifeq ($(C_COMPILER), GCC)) +ifeq ($(C_COMPILER), GCC) ifeq ($(GCCVERSIONGTEQ10), 1) CCOMMON_OPT += -Ofast -mcpu=power10 -mtune=power10 -mvsx -fno-fast-math else ifneq ($(GCCVERSIONGT4), 1) From c883abf838f33354f78f044ea9945278558173e8 Mon Sep 17 00:00:00 2001 From: Martin Kroeker Date: Wed, 22 Nov 2023 22:41:53 +0100 Subject: [PATCH 20/60] Revert unintentional change to linking rule from PR 4322 --- lapack-netlib/TESTING/LIN/Makefile | 40 +++++++++++++++--------------- 1 file changed, 20 insertions(+), 20 deletions(-) diff --git a/lapack-netlib/TESTING/LIN/Makefile b/lapack-netlib/TESTING/LIN/Makefile index 46e096c2f..714efa52a 100644 --- a/lapack-netlib/TESTING/LIN/Makefile +++ b/lapack-netlib/TESTING/LIN/Makefile @@ -269,35 +269,35 @@ proto-double: xlintstds xlintstrfd proto-complex: xlintstrfc proto-complex16: xlintstzc xlintstrfz -xlintsts: $(ALINTST) $(SLINTST) $(SCLNTST) $(TMGLIB) $(VARLIB) $(LAPACKLIB) $(XBLASLIB) $(BLASLIB) - $(FC) $(FFLAGS) $(LDFLAGS) -o $@ $^ +xlintsts: $(ALINTST) $(SLINTST) $(SCLNTST) $(TMGLIB) $(VARLIB) ../$(LAPACKLIB) $(XBLASLIB) $(BLASLIB) + $(LOADER) $(FFLAGS) $(LDFLAGS) -o $@ $^ -xlintstc: $(ALINTST) $(CLINTST) $(SCLNTST) $(TMGLIB) $(VARLIB) $(LAPACKLIB) $(XBLASLIB) $(BLASLIB) - $(FC) $(FFLAGS) $(LDFLAGS) -o $@ $^ +xlintstc: $(ALINTST) $(CLINTST) $(SCLNTST) $(TMGLIB) $(VARLIB) ../$(LAPACKLIB) $(XBLASLIB) $(BLASLIB) + $(LOADER) $(FFLAGS) $(LDFLAGS) -o $@ $^ -xlintstd: $(ALINTST) $(DLINTST) $(DZLNTST) $(TMGLIB) $(VARLIB) $(LAPACKLIB) $(XBLASLIB) $(BLASLIB) - $(FC) $(FFLAGS) $(LDFLAGS) -o $@ $^ +xlintstd: $(ALINTST) $(DLINTST) $(DZLNTST) $(TMGLIB) $(VARLIB) ../$(LAPACKLIB) $(XBLASLIB) $(BLASLIB) + $(LOADER) $(FFLAGS) $(LDFLAGS) -o $@ $^ -xlintstz: $(ALINTST) $(ZLINTST) $(DZLNTST) $(TMGLIB) $(VARLIB) $(LAPACKLIB) $(XBLASLIB) $(BLASLIB) - $(FC) $(FFLAGS) $(LDFLAGS) -o $@ $^ +xlintstz: $(ALINTST) $(ZLINTST) $(DZLNTST) $(TMGLIB) $(VARLIB) ../$(LAPACKLIB) $(XBLASLIB) $(BLASLIB) + $(LOADER) $(FFLAGS) $(LDFLAGS) -o $@ $^ -xlintstds: $(DSLINTST) $(TMGLIB) $(VARLIB) $(LAPACKLIB) $(BLASLIB) - $(FC) $(FFLAGS) $(LDFLAGS) -o $@ $^ +xlintstds: $(DSLINTST) $(TMGLIB) $(VARLIB) ../$(LAPACKLIB) $(BLASLIB) + $(LOADER) $(FFLAGS) $(LDFLAGS) -o $@ $^ -xlintstzc: $(ZCLINTST) $(TMGLIB) $(VARLIB) $(LAPACKLIB) $(BLASLIB) - $(FC) $(FFLAGS) $(LDFLAGS) -o $@ $^ +xlintstzc: $(ZCLINTST) $(TMGLIB) $(VARLIB) ../$(LAPACKLIB) $(BLASLIB) + $(LOADER) $(FFLAGS) $(LDFLAGS) -o $@ $^ -xlintstrfs: $(SLINTSTRFP) $(TMGLIB) $(VARLIB) $(LAPACKLIB) $(BLASLIB) - $(FC) $(FFLAGS) $(LDFLAGS) -o $@ $^ +xlintstrfs: $(SLINTSTRFP) $(TMGLIB) $(VARLIB) ../$(LAPACKLIB) $(BLASLIB) + $(LOADER) $(FFLAGS) $(LDFLAGS) -o $@ $^ -xlintstrfd: $(DLINTSTRFP) $(TMGLIB) $(VARLIB) $(LAPACKLIB) $(BLASLIB) - $(FC) $(FFLAGS) $(LDFLAGS) -o $@ $^ +xlintstrfd: $(DLINTSTRFP) $(TMGLIB) $(VARLIB) ../$(LAPACKLIB) $(BLASLIB) + $(LOADER) $(FFLAGS) $(LDFLAGS) -o $@ $^ -xlintstrfc: $(CLINTSTRFP) $(TMGLIB) $(VARLIB) $(LAPACKLIB) $(BLASLIB) - $(FC) $(FFLAGS) $(LDFLAGS) -o $@ $^ +xlintstrfc: $(CLINTSTRFP) $(TMGLIB) $(VARLIB) ../$(LAPACKLIB) $(BLASLIB) + $(LOADER) $(FFLAGS) $(LDFLAGS) -o $@ $^ -xlintstrfz: $(ZLINTSTRFP) $(TMGLIB) $(VARLIB) $(LAPACKLIB) $(BLASLIB) - $(FC) $(FFLAGS) $(LDFLAGS) -o $@ $^ +xlintstrfz: $(ZLINTSTRFP) $(TMGLIB) $(VARLIB) ../$(LAPACKLIB) $(BLASLIB) + $(LOADER) $(FFLAGS) $(LDFLAGS) -o $@ $^ $(ALINTST): $(FRC) $(SCLNTST): $(FRC) From f745f02f35641061511a3b2c368a21ef374c56f4 Mon Sep 17 00:00:00 2001 From: Shiyou Yin Date: Fri, 24 Nov 2023 14:51:37 +0800 Subject: [PATCH 21/60] benchmark: Fix missing colons in outputs of ./strsv.goto --- benchmark/trsv.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/benchmark/trsv.c b/benchmark/trsv.c index 66ac3a3c7..e17c57157 100644 --- a/benchmark/trsv.c +++ b/benchmark/trsv.c @@ -127,7 +127,7 @@ int main(int argc, char *argv[]){ long long muls = n*(n+1)/2.0; long long adds = (n - 1.0)*n/2.0; - fprintf(stderr, "%10d %10.2f MFlops %10.6f sec\n", n,(muls+adds) / timeg * 1.e-6, timeg); + fprintf(stderr, "%10d : %10.2f MFlops %10.6f sec\n", n,(muls+adds) / timeg * 1.e-6, timeg); if(a != NULL){ free(a); } From ca5a87ff1de25fd9d6dd22f4b4c635ec040fe59d Mon Sep 17 00:00:00 2001 From: Martin Kroeker Date: Sat, 25 Nov 2023 15:31:18 +0100 Subject: [PATCH 22/60] Small documentation fix for Truncated QR With Pivoting (Reference-LAPACK PR 941) --- lapack-netlib/SRC/cgeqp3rk.f | 12 ++++++------ lapack-netlib/SRC/claqp2rk.f | 6 +++--- lapack-netlib/SRC/claqp3rk.f | 6 +++--- lapack-netlib/SRC/dgeqp3rk.f | 4 ++-- lapack-netlib/SRC/dlaqp2rk.f | 4 ++-- lapack-netlib/SRC/dlaqp3rk.f | 4 ++-- lapack-netlib/SRC/sgeqp3rk.f | 4 ++-- lapack-netlib/SRC/slaqp2rk.f | 4 ++-- lapack-netlib/SRC/slaqp3rk.f | 4 ++-- lapack-netlib/SRC/zgeqp3rk.f | 12 ++++++------ lapack-netlib/SRC/zlaqp2rk.f | 6 +++--- lapack-netlib/SRC/zlaqp3rk.f | 6 +++--- 12 files changed, 36 insertions(+), 36 deletions(-) diff --git a/lapack-netlib/SRC/cgeqp3rk.f b/lapack-netlib/SRC/cgeqp3rk.f index 70789e64f..587860684 100644 --- a/lapack-netlib/SRC/cgeqp3rk.f +++ b/lapack-netlib/SRC/cgeqp3rk.f @@ -55,7 +55,7 @@ *> where: *> *> P(K) is an N-by-N permutation matrix; -*> Q(K) is an M-by-M orthogonal matrix; +*> Q(K) is an M-by-M unitary matrix; *> R(K)_approx = ( R11(K), R12(K) ) is a rank K approximation of the *> full rank factor R with K-by-K upper-triangular *> R11(K) and K-by-N rectangular R12(K). The diagonal @@ -124,14 +124,14 @@ *> d) RELMAXC2NRMK equals MAXC2NRMK divided by MAXC2NRM, the maximum *> column 2-norm of the original matrix A, which is equal *> to abs(R(1,1)), ( if K = min(M,N), RELMAXC2NRMK = 0.0 ); -*> e) Q(K)**H * B, the matrix B with the orthogonal +*> e) Q(K)**H * B, the matrix B with the unitary *> transformation Q(K)**H applied on the left. *> *> The N-by-N permutation matrix P(K) is stored in a compact form in *> the integer array JPIV. For 1 <= j <= N, column j *> of the matrix A was interchanged with column JPIV(j). *> -*> The M-by-M orthogonal matrix Q is represented as a product +*> The M-by-M unitary matrix Q is represented as a product *> of elementary Householder reflectors *> *> Q(K) = H(1) * H(2) * . . . * H(K), @@ -300,7 +300,7 @@ *> *> 1. The elements below the diagonal of the subarray *> A(1:M,1:K) together with TAU(1:K) represent the -*> orthogonal matrix Q(K) as a product of K Householder +*> unitary matrix Q(K) as a product of K Householder *> elementary reflectors. *> *> 2. The elements on and above the diagonal of @@ -579,8 +579,8 @@ *> \verbatim *> *> November 2023, Igor Kozachenko, James Demmel, -*> Computer Science Division, -*> University of California, Berkeley +*> EECS Department, +*> University of California, Berkeley, USA. *> *> \endverbatim * diff --git a/lapack-netlib/SRC/claqp2rk.f b/lapack-netlib/SRC/claqp2rk.f index 073ad0f88..6b1db085a 100644 --- a/lapack-netlib/SRC/claqp2rk.f +++ b/lapack-netlib/SRC/claqp2rk.f @@ -178,7 +178,7 @@ *> On exit: *> 1. The elements in block A(IOFFSET+1:M,1:K) below *> the diagonal together with the array TAU represent -*> the orthogonal matrix Q(K) as a product of elementary +*> the unitary matrix Q(K) as a product of elementary *> reflectors. *> 2. The upper triangular block of the matrix A stored *> in A(IOFFSET+1:M,1:K) is the triangular factor obtained. @@ -332,8 +332,8 @@ *> \verbatim *> *> November 2023, Igor Kozachenko, James Demmel, -*> Computer Science Division, -*> University of California, Berkeley +*> EECS Department, +*> University of California, Berkeley, USA. *> *> \endverbatim * diff --git a/lapack-netlib/SRC/claqp3rk.f b/lapack-netlib/SRC/claqp3rk.f index af5e85645..3703bcbd6 100644 --- a/lapack-netlib/SRC/claqp3rk.f +++ b/lapack-netlib/SRC/claqp3rk.f @@ -196,7 +196,7 @@ *> On exit: *> 1. The elements in block A(IOFFSET+1:M,1:KB) below *> the diagonal together with the array TAU represent -*> the orthogonal matrix Q(KB) as a product of elementary +*> the unitary matrix Q(KB) as a product of elementary *> reflectors. *> 2. The upper triangular block of the matrix A stored *> in A(IOFFSET+1:M,1:KB) is the triangular factor obtained. @@ -383,8 +383,8 @@ *> \verbatim *> *> November 2023, Igor Kozachenko, James Demmel, -*> Computer Science Division, -*> University of California, Berkeley +*> EECS Department, +*> University of California, Berkeley, USA. *> *> \endverbatim * diff --git a/lapack-netlib/SRC/dgeqp3rk.f b/lapack-netlib/SRC/dgeqp3rk.f index ace97b712..117a68287 100644 --- a/lapack-netlib/SRC/dgeqp3rk.f +++ b/lapack-netlib/SRC/dgeqp3rk.f @@ -573,8 +573,8 @@ *> \verbatim *> *> November 2023, Igor Kozachenko, James Demmel, -*> Computer Science Division, -*> University of California, Berkeley +*> EECS Department, +*> University of California, Berkeley, USA. *> *> \endverbatim * diff --git a/lapack-netlib/SRC/dlaqp2rk.f b/lapack-netlib/SRC/dlaqp2rk.f index b5a84d0de..aecd6bb69 100644 --- a/lapack-netlib/SRC/dlaqp2rk.f +++ b/lapack-netlib/SRC/dlaqp2rk.f @@ -331,8 +331,8 @@ *> \verbatim *> *> November 2023, Igor Kozachenko, James Demmel, -*> Computer Science Division, -*> University of California, Berkeley +*> EECS Department, +*> University of California, Berkeley, USA. *> *> \endverbatim * diff --git a/lapack-netlib/SRC/dlaqp3rk.f b/lapack-netlib/SRC/dlaqp3rk.f index 39e617d0e..8139345ed 100644 --- a/lapack-netlib/SRC/dlaqp3rk.f +++ b/lapack-netlib/SRC/dlaqp3rk.f @@ -389,8 +389,8 @@ *> \verbatim *> *> November 2023, Igor Kozachenko, James Demmel, -*> Computer Science Division, -*> University of California, Berkeley +*> EECS Department, +*> University of California, Berkeley, USA. *> *> \endverbatim * diff --git a/lapack-netlib/SRC/sgeqp3rk.f b/lapack-netlib/SRC/sgeqp3rk.f index 17559c7f4..bb5da72dc 100644 --- a/lapack-netlib/SRC/sgeqp3rk.f +++ b/lapack-netlib/SRC/sgeqp3rk.f @@ -573,8 +573,8 @@ *> \verbatim *> *> November 2023, Igor Kozachenko, James Demmel, -*> Computer Science Division, -*> University of California, Berkeley +*> EECS Department, +*> University of California, Berkeley, USA. *> *> \endverbatim * diff --git a/lapack-netlib/SRC/slaqp2rk.f b/lapack-netlib/SRC/slaqp2rk.f index d3dbb3d7c..f88b0ce90 100644 --- a/lapack-netlib/SRC/slaqp2rk.f +++ b/lapack-netlib/SRC/slaqp2rk.f @@ -331,8 +331,8 @@ *> \verbatim *> *> November 2023, Igor Kozachenko, James Demmel, -*> Computer Science Division, -*> University of California, Berkeley +*> EECS Department, +*> University of California, Berkeley, USA. *> *> \endverbatim * diff --git a/lapack-netlib/SRC/slaqp3rk.f b/lapack-netlib/SRC/slaqp3rk.f index fa735bb9d..b2dc2b334 100644 --- a/lapack-netlib/SRC/slaqp3rk.f +++ b/lapack-netlib/SRC/slaqp3rk.f @@ -389,8 +389,8 @@ *> \verbatim *> *> November 2023, Igor Kozachenko, James Demmel, -*> Computer Science Division, -*> University of California, Berkeley +*> EECS Department, +*> University of California, Berkeley, USA. *> *> \endverbatim * diff --git a/lapack-netlib/SRC/zgeqp3rk.f b/lapack-netlib/SRC/zgeqp3rk.f index f8ef986c7..247a3c379 100644 --- a/lapack-netlib/SRC/zgeqp3rk.f +++ b/lapack-netlib/SRC/zgeqp3rk.f @@ -55,7 +55,7 @@ *> where: *> *> P(K) is an N-by-N permutation matrix; -*> Q(K) is an M-by-M orthogonal matrix; +*> Q(K) is an M-by-M unitary matrix; *> R(K)_approx = ( R11(K), R12(K) ) is a rank K approximation of the *> full rank factor R with K-by-K upper-triangular *> R11(K) and K-by-N rectangular R12(K). The diagonal @@ -124,14 +124,14 @@ *> d) RELMAXC2NRMK equals MAXC2NRMK divided by MAXC2NRM, the maximum *> column 2-norm of the original matrix A, which is equal *> to abs(R(1,1)), ( if K = min(M,N), RELMAXC2NRMK = 0.0 ); -*> e) Q(K)**H * B, the matrix B with the orthogonal +*> e) Q(K)**H * B, the matrix B with the unitary *> transformation Q(K)**H applied on the left. *> *> The N-by-N permutation matrix P(K) is stored in a compact form in *> the integer array JPIV. For 1 <= j <= N, column j *> of the matrix A was interchanged with column JPIV(j). *> -*> The M-by-M orthogonal matrix Q is represented as a product +*> The M-by-M unitary matrix Q is represented as a product *> of elementary Householder reflectors *> *> Q(K) = H(1) * H(2) * . . . * H(K), @@ -300,7 +300,7 @@ *> *> 1. The elements below the diagonal of the subarray *> A(1:M,1:K) together with TAU(1:K) represent the -*> orthogonal matrix Q(K) as a product of K Householder +*> unitary matrix Q(K) as a product of K Householder *> elementary reflectors. *> *> 2. The elements on and above the diagonal of @@ -579,8 +579,8 @@ *> \verbatim *> *> November 2023, Igor Kozachenko, James Demmel, -*> Computer Science Division, -*> University of California, Berkeley +*> EECS Department, +*> University of California, Berkeley, USA. *> *> \endverbatim * diff --git a/lapack-netlib/SRC/zlaqp2rk.f b/lapack-netlib/SRC/zlaqp2rk.f index f1e9f4899..f6bf555c2 100644 --- a/lapack-netlib/SRC/zlaqp2rk.f +++ b/lapack-netlib/SRC/zlaqp2rk.f @@ -178,7 +178,7 @@ *> On exit: *> 1. The elements in block A(IOFFSET+1:M,1:K) below *> the diagonal together with the array TAU represent -*> the orthogonal matrix Q(K) as a product of elementary +*> the unitary matrix Q(K) as a product of elementary *> reflectors. *> 2. The upper triangular block of the matrix A stored *> in A(IOFFSET+1:M,1:K) is the triangular factor obtained. @@ -332,8 +332,8 @@ *> \verbatim *> *> November 2023, Igor Kozachenko, James Demmel, -*> Computer Science Division, -*> University of California, Berkeley +*> EECS Department, +*> University of California, Berkeley, USA. *> *> \endverbatim * diff --git a/lapack-netlib/SRC/zlaqp3rk.f b/lapack-netlib/SRC/zlaqp3rk.f index 7a9fdfd95..0dd8bf8e3 100644 --- a/lapack-netlib/SRC/zlaqp3rk.f +++ b/lapack-netlib/SRC/zlaqp3rk.f @@ -196,7 +196,7 @@ *> On exit: *> 1. The elements in block A(IOFFSET+1:M,1:KB) below *> the diagonal together with the array TAU represent -*> the orthogonal matrix Q(KB) as a product of elementary +*> the unitary matrix Q(KB) as a product of elementary *> reflectors. *> 2. The upper triangular block of the matrix A stored *> in A(IOFFSET+1:M,1:KB) is the triangular factor obtained. @@ -383,8 +383,8 @@ *> \verbatim *> *> November 2023, Igor Kozachenko, James Demmel, -*> Computer Science Division, -*> University of California, Berkeley +*> EECS Department, +*> University of California, Berkeley, USA. *> *> \endverbatim * From f7351e493c6ce928e5c924c15d709c3de7c62d7b Mon Sep 17 00:00:00 2001 From: Martin Kroeker Date: Sat, 25 Nov 2023 18:49:34 +0100 Subject: [PATCH 23/60] Update Reference-LAPACK docs to 3.12.0 --- lapack-netlib/DOCS/Doxyfile | 478 +++++--- lapack-netlib/DOCS/DoxygenLayout.xml | 197 ++++ lapack-netlib/DOCS/groups-usr.dox | 1575 ++++++++++++++++---------- 3 files changed, 1480 insertions(+), 770 deletions(-) create mode 100644 lapack-netlib/DOCS/DoxygenLayout.xml diff --git a/lapack-netlib/DOCS/Doxyfile b/lapack-netlib/DOCS/Doxyfile index 43cea43b5..577675772 100644 --- a/lapack-netlib/DOCS/Doxyfile +++ b/lapack-netlib/DOCS/Doxyfile @@ -1,4 +1,4 @@ -# Doxyfile 1.8.10 +# Doxyfile 1.9.1 # This file describes the settings to be used by the documentation system # doxygen (www.doxygen.org) for a project. @@ -17,11 +17,11 @@ # Project related configuration options #--------------------------------------------------------------------------- -# This tag specifies the encoding used for all characters in the config file -# that follow. The default is UTF-8 which is also the encoding used for all text -# before the first occurrence of this tag. Doxygen uses libiconv (or the iconv -# built into libc) for the transcoding. See http://www.gnu.org/software/libiconv -# for the list of possible encodings. +# This tag specifies the encoding used for all characters in the configuration +# file that follow. The default is UTF-8 which is also the encoding used for all +# text before the first occurrence of this tag. Doxygen uses libiconv (or the +# iconv built into libc) for the transcoding. See +# https://www.gnu.org/software/libiconv/ for the list of possible encodings. # The default value is: UTF-8. DOXYFILE_ENCODING = UTF-8 @@ -38,7 +38,7 @@ PROJECT_NAME = LAPACK # could be handy for archiving the generated documentation or if some version # control system is used. -PROJECT_NUMBER = 3.9.0 +PROJECT_NUMBER = 3.12.0 # Using the PROJECT_BRIEF tag one can provide an optional one line description # for a project that appears at the top of each page and should give viewer a @@ -93,6 +93,14 @@ ALLOW_UNICODE_NAMES = NO OUTPUT_LANGUAGE = English +# The OUTPUT_TEXT_DIRECTION tag is used to specify the direction in which all +# documentation generated by doxygen is written. Doxygen will use this +# information to generate all generated output in the proper direction. +# Possible values are: None, LTR, RTL and Context. +# The default value is: None. + +OUTPUT_TEXT_DIRECTION = None + # If the BRIEF_MEMBER_DESC tag is set to YES, doxygen will include brief member # descriptions after the members that are listed in the file and class # documentation (similar to Javadoc). Set to NO to disable this. @@ -179,6 +187,16 @@ SHORT_NAMES = NO JAVADOC_AUTOBRIEF = NO +# If the JAVADOC_BANNER tag is set to YES then doxygen will interpret a line +# such as +# /*************** +# as being the beginning of a Javadoc-style comment "banner". If set to NO, the +# Javadoc-style will behave just like regular comments and it will not be +# interpreted by doxygen. +# The default value is: NO. + +JAVADOC_BANNER = NO + # If the QT_AUTOBRIEF tag is set to YES then doxygen will interpret the first # line (until the first dot) of a Qt-style comment as the brief description. If # set to NO, the Qt-style will behave just like regular Qt-style comments (thus @@ -199,6 +217,14 @@ QT_AUTOBRIEF = NO MULTILINE_CPP_IS_BRIEF = NO +# By default Python docstrings are displayed as preformatted text and doxygen's +# special commands cannot be used. By setting PYTHON_DOCSTRING to NO the +# doxygen's special commands can be used and the contents of the docstring +# documentation blocks is shown as doxygen documentation. +# The default value is: YES. + +PYTHON_DOCSTRING = YES + # If the INHERIT_DOCS tag is set to YES then an undocumented member inherits the # documentation from any documented member that it re-implements. # The default value is: YES. @@ -226,16 +252,15 @@ TAB_SIZE = 8 # will allow you to put the command \sideeffect (or @sideeffect) in the # documentation, which will result in a user-defined paragraph with heading # "Side Effects:". You can put \n's in the value part of an alias to insert -# newlines. +# newlines (in the resulting output). You can put ^^ in the value part of an +# alias to insert a newline as if a physical newline was in the original file. +# When you need a literal { or } or , in the value part of an alias you have to +# escape them by means of a backslash (\), this can lead to conflicts with the +# commands \{ and \} for these it is advised to use the version @{ and @} or use +# a double escape (\\{ and \\}) ALIASES = -# This tag can be used to specify a number of word-keyword mappings (TCL only). -# A mapping has the form "name=value". For example adding "class=itcl::class" -# will allow you to use the command class in the itcl::class meaning. - -TCL_SUBST = - # Set the OPTIMIZE_OUTPUT_FOR_C tag to YES if your project consists of C sources # only. Doxygen will then generate output that is more tailored for C. For # instance, some of the names that are used will be different. The list of all @@ -264,28 +289,40 @@ OPTIMIZE_FOR_FORTRAN = YES OPTIMIZE_OUTPUT_VHDL = NO +# Set the OPTIMIZE_OUTPUT_SLICE tag to YES if your project consists of Slice +# sources only. Doxygen will then generate output that is more tailored for that +# language. For instance, namespaces will be presented as modules, types will be +# separated into more groups, etc. +# The default value is: NO. + +OPTIMIZE_OUTPUT_SLICE = NO + # Doxygen selects the parser to use depending on the extension of the files it # parses. With this tag you can assign which parser to use for a given # extension. Doxygen has a built-in mapping, but you can override or extend it # using this tag. The format is ext=language, where ext is a file extension, and -# language is one of the parsers supported by doxygen: IDL, Java, Javascript, -# C#, C, C++, D, PHP, Objective-C, Python, Fortran (fixed format Fortran: -# FortranFixed, free formatted Fortran: FortranFree, unknown formatted Fortran: -# Fortran. In the later case the parser tries to guess whether the code is fixed -# or free formatted code, this is the default for Fortran type files), VHDL. For -# instance to make doxygen treat .inc files as Fortran files (default is PHP), -# and .f files as C (default is Fortran), use: inc=Fortran f=C. +# language is one of the parsers supported by doxygen: IDL, Java, JavaScript, +# Csharp (C#), C, C++, D, PHP, md (Markdown), Objective-C, Python, Slice, VHDL, +# Fortran (fixed format Fortran: FortranFixed, free formatted Fortran: +# FortranFree, unknown formatted Fortran: Fortran. In the later case the parser +# tries to guess whether the code is fixed or free formatted code, this is the +# default for Fortran type files). For instance to make doxygen treat .inc files +# as Fortran files (default is PHP), and .f files as C (default is Fortran), +# use: inc=Fortran f=C. # # Note: For files without extension you can use no_extension as a placeholder. # # Note that for custom extensions you also need to set FILE_PATTERNS otherwise -# the files are not read by doxygen. +# the files are not read by doxygen. When specifying no_extension you should add +# * to the FILE_PATTERNS. +# +# Note see also the list of default file extension mappings. EXTENSION_MAPPING = # If the MARKDOWN_SUPPORT tag is enabled then doxygen pre-processes all comments # according to the Markdown format, which allows for more readable -# documentation. See http://daringfireball.net/projects/markdown/ for details. +# documentation. See https://daringfireball.net/projects/markdown/ for details. # The output of markdown processing is further processed by doxygen, so you can # mix doxygen, HTML, and XML commands with Markdown formatting. Disable only in # case of backward compatibilities issues. @@ -293,6 +330,15 @@ EXTENSION_MAPPING = MARKDOWN_SUPPORT = YES +# When the TOC_INCLUDE_HEADINGS tag is set to a non-zero value, all headings up +# to that level are automatically included in the table of contents, even if +# they do not have an id attribute. +# Note: This feature currently applies only to Markdown headings. +# Minimum value: 0, maximum value: 99, default value: 5. +# This tag requires that the tag MARKDOWN_SUPPORT is set to YES. + +TOC_INCLUDE_HEADINGS = 5 + # When enabled doxygen tries to link words that correspond to documented # classes, or namespaces to their corresponding documentation. Such a link can # be prevented in individual cases by putting a % sign in front of the word or @@ -318,7 +364,7 @@ BUILTIN_STL_SUPPORT = NO CPP_CLI_SUPPORT = NO # Set the SIP_SUPPORT tag to YES if your project consists of sip (see: -# http://www.riverbankcomputing.co.uk/software/sip/intro) sources only. Doxygen +# https://www.riverbankcomputing.com/software/sip/intro) sources only. Doxygen # will parse them like normal C++ but will assume all classes use public instead # of private inheritance when no explicit protection keyword is present. # The default value is: NO. @@ -341,7 +387,7 @@ IDL_PROPERTY_SUPPORT = YES # all members of a group must be documented explicitly. # The default value is: NO. -DISTRIBUTE_GROUP_DOC = YES +DISTRIBUTE_GROUP_DOC = NO # If one adds a struct or class to a group and this option is enabled, then also # any nested class or struct is added to the same group. By default this option @@ -404,6 +450,19 @@ TYPEDEF_HIDES_STRUCT = NO LOOKUP_CACHE_SIZE = 0 +# The NUM_PROC_THREADS specifies the number threads doxygen is allowed to use +# during processing. When set to 0 doxygen will based this on the number of +# cores available in the system. You can set it explicitly to a value larger +# than 0 to get more control over the balance between CPU load and processing +# speed. At this moment only the input processing can be done using multiple +# threads. Since this is still an experimental feature the default is set to 1, +# which efficively disables parallel processing. Please report any issues you +# encounter. Generating dot graphs in parallel is controlled by the +# DOT_NUM_THREADS setting. +# Minimum value: 0, maximum value: 32, default value: 1. + +NUM_PROC_THREADS = 1 + #--------------------------------------------------------------------------- # Build related configuration options #--------------------------------------------------------------------------- @@ -424,6 +483,12 @@ EXTRACT_ALL = YES EXTRACT_PRIVATE = NO +# If the EXTRACT_PRIV_VIRTUAL tag is set to YES, documented private virtual +# methods of a class will be included in the documentation. +# The default value is: NO. + +EXTRACT_PRIV_VIRTUAL = NO + # If the EXTRACT_PACKAGE tag is set to YES, all members with package or internal # scope will be included in the documentation. # The default value is: NO. @@ -461,6 +526,13 @@ EXTRACT_LOCAL_METHODS = NO EXTRACT_ANON_NSPACES = NO +# If this flag is set to YES, the name of an unnamed parameter in a declaration +# will be determined by the corresponding definition. By default unnamed +# parameters remain unnamed in the output. +# The default value is: YES. + +RESOLVE_UNNAMED_PARAMS = YES + # If the HIDE_UNDOC_MEMBERS tag is set to YES, doxygen will hide all # undocumented members inside documented classes or files. If set to NO these # members will be included in the various overviews, but no documentation @@ -478,8 +550,8 @@ HIDE_UNDOC_MEMBERS = NO HIDE_UNDOC_CLASSES = NO # If the HIDE_FRIEND_COMPOUNDS tag is set to YES, doxygen will hide all friend -# (class|struct|union) declarations. If set to NO, these declarations will be -# included in the documentation. +# declarations. If set to NO, these declarations will be included in the +# documentation. # The default value is: NO. HIDE_FRIEND_COMPOUNDS = NO @@ -498,11 +570,18 @@ HIDE_IN_BODY_DOCS = NO INTERNAL_DOCS = NO -# If the CASE_SENSE_NAMES tag is set to NO then doxygen will only generate file -# names in lower-case letters. If set to YES, upper-case letters are also -# allowed. This is useful if you have classes or files whose names only differ -# in case and if your file system supports case sensitive file names. Windows -# and Mac users are advised to set this option to NO. +# With the correct setting of option CASE_SENSE_NAMES doxygen will better be +# able to match the capabilities of the underlying filesystem. In case the +# filesystem is case sensitive (i.e. it supports files in the same directory +# whose names only differ in casing), the option must be set to YES to properly +# deal with such files in case they appear in the input. For filesystems that +# are not case sensitive the option should be be set to NO to properly deal with +# output files written for symbols that only differ in casing, such as for two +# classes, one named CLASS and the other named Class, and to also support +# references to files without having to specify the exact matching casing. On +# Windows (including Cygwin) and MacOS, users should typically set this option +# to NO, whereas on Linux or other Unix flavors it should typically be set to +# YES. # The default value is: system dependent. CASE_SENSE_NAMES = NO @@ -684,12 +763,12 @@ FILE_VERSION_FILTER = # DoxygenLayout.xml, doxygen will parse it automatically even if the LAYOUT_FILE # tag is left empty. -LAYOUT_FILE = +LAYOUT_FILE = DOCS/DoxygenLayout.xml # The CITE_BIB_FILES tag can be used to specify one or more bib files containing # the reference definitions. This must be a list of .bib files. The .bib # extension is automatically appended if omitted. This requires the bibtex tool -# to be installed. See also http://en.wikipedia.org/wiki/BibTeX for more info. +# to be installed. See also https://en.wikipedia.org/wiki/BibTeX for more info. # For LaTeX the style of the bibliography can be controlled using # LATEX_BIB_STYLE. To use this feature you need bibtex and perl available in the # search path. See also \cite for info how to create references. @@ -705,7 +784,7 @@ CITE_BIB_FILES = # messages are off. # The default value is: NO. -QUIET = YES +QUIET = NO # The WARNINGS tag can be used to turn on/off the warning messages that are # generated to standard error (stderr) by doxygen. If WARNINGS is set to YES @@ -734,10 +813,20 @@ WARN_IF_DOC_ERROR = YES # This WARN_NO_PARAMDOC option can be enabled to get warnings for functions that # are documented, but have no documentation for their parameters or return # value. If set to NO, doxygen will only warn about wrong or incomplete -# parameter documentation, but not about the absence of documentation. +# parameter documentation, but not about the absence of documentation. If +# EXTRACT_ALL is set to YES then this flag will automatically be disabled. # The default value is: NO. -WARN_NO_PARAMDOC = NO +WARN_NO_PARAMDOC = YES + +# If the WARN_AS_ERROR tag is set to YES then doxygen will immediately stop when +# a warning is encountered. If the WARN_AS_ERROR tag is set to FAIL_ON_WARNINGS +# then doxygen will continue running as if WARN_AS_ERROR tag is set to NO, but +# at the end of the doxygen process doxygen will return with a non-zero status. +# Possible values are: NO, YES and FAIL_ON_WARNINGS. +# The default value is: NO. + +WARN_AS_ERROR = NO # The WARN_FORMAT tag determines the format of the warning messages that doxygen # can produce. The string should contain the $file, $line, and $text tags, which @@ -753,7 +842,7 @@ WARN_FORMAT = "$file:$line: $text" # messages should be written. If left blank the output is written to standard # error (stderr). -WARN_LOGFILE = output_err +WARN_LOGFILE = doxygen_error #--------------------------------------------------------------------------- # Configuration options related to the input files @@ -762,17 +851,18 @@ WARN_LOGFILE = output_err # The INPUT tag is used to specify the files and/or directories that contain # documented source files. You may enter file names like myfile.cpp or # directories like /usr/src/myproject. Separate the files or directories with -# spaces. +# spaces. See also FILE_PATTERNS and EXTENSION_MAPPING # Note: If this tag is empty the current directory is searched. -INPUT = . \ - DOCS/groups-usr.dox +INPUT = BLAS CBLAS SRC INSTALL TESTING \ + DOCS/groups-usr.dox \ + README.md # This tag can be used to specify the character encoding of the source files # that doxygen parses. Internally doxygen uses the UTF-8 encoding. Doxygen uses # libiconv (or the iconv built into libc) for the transcoding. See the libiconv -# documentation (see: http://www.gnu.org/software/libiconv) for the list of -# possible encodings. +# documentation (see: +# https://www.gnu.org/software/libiconv/) for the list of possible encodings. # The default value is: UTF-8. INPUT_ENCODING = UTF-8 @@ -785,14 +875,19 @@ INPUT_ENCODING = UTF-8 # need to set EXTENSION_MAPPING for the extension otherwise the files are not # read by doxygen. # +# Note the list of default checked file patterns might differ from the list of +# default file extension mappings. +# # If left blank the following patterns are tested:*.c, *.cc, *.cxx, *.cpp, # *.c++, *.java, *.ii, *.ixx, *.ipp, *.i++, *.inl, *.idl, *.ddl, *.odl, *.h, # *.hh, *.hxx, *.hpp, *.h++, *.cs, *.d, *.php, *.php4, *.php5, *.phtml, *.inc, -# *.m, *.markdown, *.md, *.mm, *.dox, *.py, *.f90, *.f, *.for, *.tcl, *.vhd, -# *.vhdl, *.ucf, *.qsf, *.as and *.js. +# *.m, *.markdown, *.md, *.mm, *.dox (to be provided as doxygen C comment), +# *.py, *.pyw, *.f90, *.f95, *.f03, *.f08, *.f18, *.f, *.for, *.vhd, *.vhdl, +# *.ucf, *.qsf and *.ice. FILE_PATTERNS = *.c \ *.f \ + *.f90 \ *.h # The RECURSIVE tag can be used to specify whether or not subdirectories should @@ -808,34 +903,15 @@ RECURSIVE = YES # Note that relative paths are relative to the directory from which doxygen is # run. -EXCLUDE = CMAKE \ - DOCS \ - .svn \ - CBLAS/.svn \ - CBLAS/src/.svn \ - CBLAS/testing/.svn \ - CBLAS/example/.svn \ - CBLAS/include/.svn \ - BLAS/.svn \ - BLAS/SRC/.svn \ - BLAS/TESTING/.svn \ - SRC/.svn \ - SRC/VARIANTS/.svn \ - SRC/VARIANTS/LIB/.svn \ - SRC/VARIANTS/cholesky/.svn \ - SRC/VARIANTS/cholesky/RL/.svn \ - SRC/VARIANTS/cholesky/TOP/.svn \ - SRC/VARIANTS/lu/.svn \ - SRC/VARIANTS/lu/CR/.svn \ - SRC/VARIANTS/lu/LL/.svn \ - SRC/VARIANTS/lu/REC/.svn \ - SRC/VARIANTS/qr/.svn \ - SRC/VARIANTS/qr/LL/.svn \ - INSTALL/.svn \ - TESTING/.svn \ - TESTING/EIG/.svn \ - TESTING/MATGEN/.svn \ - TESTING/LIN/.svn +# Exclude functions that are duplicated, creating conflicts. +EXCLUDE = .git \ + .github \ + SRC/VARIANTS \ + BLAS/SRC/lsame.f \ + BLAS/SRC/xerbla.f \ + BLAS/SRC/xerbla_array.f \ + INSTALL/slamchf77.f \ + INSTALL/dlamchf77.f \ # The EXCLUDE_SYMLINKS tag can be used to select whether or not files or # directories that are symbolic links (a Unix file system feature) are excluded @@ -908,6 +984,10 @@ IMAGE_PATH = # Note that the filter must not add or remove lines; it is applied before the # code is scanned, but not when the output code is generated. If lines are added # or removed, the anchors will not be placed correctly. +# +# Note that for custom extensions or not directly supported extensions you also +# need to set EXTENSION_MAPPING for the extension otherwise the files are not +# properly processed by doxygen. INPUT_FILTER = @@ -917,6 +997,10 @@ INPUT_FILTER = # (like *.cpp=my_cpp_filter). See INPUT_FILTER for further information on how # filters are used. If the FILTER_PATTERNS tag is empty or if none of the # patterns match the file name, INPUT_FILTER is applied. +# +# Note that for custom extensions or not directly supported extensions you also +# need to set EXTENSION_MAPPING for the extension otherwise the files are not +# properly processed by doxygen. FILTER_PATTERNS = @@ -969,7 +1053,7 @@ INLINE_SOURCES = YES STRIP_CODE_COMMENTS = YES # If the REFERENCED_BY_RELATION tag is set to YES then for each documented -# function all documented functions referencing it will be listed. +# entity all documented functions referencing it will be listed. # The default value is: NO. REFERENCED_BY_RELATION = NO @@ -1001,12 +1085,12 @@ SOURCE_TOOLTIPS = YES # If the USE_HTAGS tag is set to YES then the references to source code will # point to the HTML generated by the htags(1) tool instead of doxygen built-in # source browser. The htags tool is part of GNU's global source tagging system -# (see http://www.gnu.org/software/global/global.html). You will need version +# (see https://www.gnu.org/software/global/global.html). You will need version # 4.8.6 or higher. # # To use it do the following: # - Install the latest version of global -# - Enable SOURCE_BROWSER and USE_HTAGS in the config file +# - Enable SOURCE_BROWSER and USE_HTAGS in the configuration file # - Make sure the INPUT points to the root of the source tree # - Run doxygen as normal # @@ -1028,25 +1112,6 @@ USE_HTAGS = NO VERBATIM_HEADERS = YES -# If the CLANG_ASSISTED_PARSING tag is set to YES then doxygen will use the -# clang parser (see: http://clang.llvm.org/) for more accurate parsing at the -# cost of reduced performance. This can be particularly helpful with template -# rich C++ code for which doxygen's built-in parser lacks the necessary type -# information. -# Note: The availability of this option depends on whether or not doxygen was -# compiled with the --with-libclang option. -# The default value is: NO. - -CLANG_ASSISTED_PARSING = NO - -# If clang assisted parsing is enabled you can provide the compiler with command -# line options that you would normally use when invoking the compiler. Note that -# the include paths will already be set by doxygen for the files and directories -# specified with INPUT and INCLUDE_PATH. -# This tag requires that the tag CLANG_ASSISTED_PARSING is set to YES. - -CLANG_OPTIONS = - #--------------------------------------------------------------------------- # Configuration options related to the alphabetical class index #--------------------------------------------------------------------------- @@ -1058,13 +1123,6 @@ CLANG_OPTIONS = ALPHABETICAL_INDEX = YES -# The COLS_IN_ALPHA_INDEX tag can be used to specify the number of columns in -# which the alphabetical index list will be split. -# Minimum value: 1, maximum value: 20, default value: 5. -# This tag requires that the tag ALPHABETICAL_INDEX is set to YES. - -COLS_IN_ALPHA_INDEX = 5 - # In case all classes in a project start with a common prefix, all classes will # be put under the same header in the alphabetical index. The IGNORE_PREFIX tag # can be used to specify a prefix (or a list of prefixes) that should be ignored @@ -1165,7 +1223,7 @@ HTML_EXTRA_FILES = # The HTML_COLORSTYLE_HUE tag controls the color of the HTML output. Doxygen # will adjust the colors in the style sheet and background images according to # this color. Hue is specified as an angle on a colorwheel, see -# http://en.wikipedia.org/wiki/Hue for more information. For instance the value +# https://en.wikipedia.org/wiki/Hue for more information. For instance the value # 0 represents red, 60 is yellow, 120 is green, 180 is cyan, 240 is blue, 300 # purple, and 360 is red again. # Minimum value: 0, maximum value: 359, default value: 220. @@ -1201,6 +1259,17 @@ HTML_COLORSTYLE_GAMMA = 80 HTML_TIMESTAMP = YES +# If the HTML_DYNAMIC_MENUS tag is set to YES then the generated HTML +# documentation will contain a main index with vertical navigation menus that +# are dynamically created via JavaScript. If disabled, the navigation index will +# consists of multiple levels of tabs that are statically embedded in every HTML +# page. Disable this option to support browsers that do not have JavaScript, +# like the Qt help browser. +# The default value is: YES. +# This tag requires that the tag GENERATE_HTML is set to YES. + +HTML_DYNAMIC_MENUS = YES + # If the HTML_DYNAMIC_SECTIONS tag is set to YES then the generated HTML # documentation will contain sections that can be hidden and shown after the # page has loaded. @@ -1224,13 +1293,14 @@ HTML_INDEX_NUM_ENTRIES = 100 # If the GENERATE_DOCSET tag is set to YES, additional index files will be # generated that can be used as input for Apple's Xcode 3 integrated development -# environment (see: http://developer.apple.com/tools/xcode/), introduced with -# OSX 10.5 (Leopard). To create a documentation set, doxygen will generate a -# Makefile in the HTML output directory. Running make will produce the docset in -# that directory and running make install will install the docset in +# environment (see: +# https://developer.apple.com/xcode/), introduced with OSX 10.5 (Leopard). To +# create a documentation set, doxygen will generate a Makefile in the HTML +# output directory. Running make will produce the docset in that directory and +# running make install will install the docset in # ~/Library/Developer/Shared/Documentation/DocSets so that Xcode will find it at -# startup. See http://developer.apple.com/tools/creatingdocsetswithdoxygen.html -# for more information. +# startup. See https://developer.apple.com/library/archive/featuredarticles/Doxy +# genXcode/_index.html for more information. # The default value is: NO. # This tag requires that the tag GENERATE_HTML is set to YES. @@ -1269,8 +1339,8 @@ DOCSET_PUBLISHER_NAME = Publisher # If the GENERATE_HTMLHELP tag is set to YES then doxygen generates three # additional HTML index files: index.hhp, index.hhc, and index.hhk. The # index.hhp is a project file that can be read by Microsoft's HTML Help Workshop -# (see: http://www.microsoft.com/en-us/download/details.aspx?id=21138) on -# Windows. +# (see: +# https://www.microsoft.com/en-us/download/details.aspx?id=21138) on Windows. # # The HTML Help Workshop contains a compiler that can convert all HTML output # generated by doxygen into a single compiled HTML file (.chm). Compiled HTML @@ -1300,7 +1370,7 @@ CHM_FILE = HHC_LOCATION = # The GENERATE_CHI flag controls if a separate .chi index file is generated -# (YES) or that it should be included in the master .chm file (NO). +# (YES) or that it should be included in the main .chm file (NO). # The default value is: NO. # This tag requires that the tag GENERATE_HTMLHELP is set to YES. @@ -1345,7 +1415,8 @@ QCH_FILE = # The QHP_NAMESPACE tag specifies the namespace to use when generating Qt Help # Project output. For more information please see Qt Help Project / Namespace -# (see: http://qt-project.org/doc/qt-4.8/qthelpproject.html#namespace). +# (see: +# https://doc.qt.io/archives/qt-4.8/qthelpproject.html#namespace). # The default value is: org.doxygen.Project. # This tag requires that the tag GENERATE_QHP is set to YES. @@ -1353,8 +1424,8 @@ QHP_NAMESPACE = org.doxygen.Project # The QHP_VIRTUAL_FOLDER tag specifies the namespace to use when generating Qt # Help Project output. For more information please see Qt Help Project / Virtual -# Folders (see: http://qt-project.org/doc/qt-4.8/qthelpproject.html#virtual- -# folders). +# Folders (see: +# https://doc.qt.io/archives/qt-4.8/qthelpproject.html#virtual-folders). # The default value is: doc. # This tag requires that the tag GENERATE_QHP is set to YES. @@ -1362,30 +1433,30 @@ QHP_VIRTUAL_FOLDER = doc # If the QHP_CUST_FILTER_NAME tag is set, it specifies the name of a custom # filter to add. For more information please see Qt Help Project / Custom -# Filters (see: http://qt-project.org/doc/qt-4.8/qthelpproject.html#custom- -# filters). +# Filters (see: +# https://doc.qt.io/archives/qt-4.8/qthelpproject.html#custom-filters). # This tag requires that the tag GENERATE_QHP is set to YES. QHP_CUST_FILTER_NAME = # The QHP_CUST_FILTER_ATTRS tag specifies the list of the attributes of the # custom filter to add. For more information please see Qt Help Project / Custom -# Filters (see: http://qt-project.org/doc/qt-4.8/qthelpproject.html#custom- -# filters). +# Filters (see: +# https://doc.qt.io/archives/qt-4.8/qthelpproject.html#custom-filters). # This tag requires that the tag GENERATE_QHP is set to YES. QHP_CUST_FILTER_ATTRS = # The QHP_SECT_FILTER_ATTRS tag specifies the list of the attributes this # project's filter section matches. Qt Help Project / Filter Attributes (see: -# http://qt-project.org/doc/qt-4.8/qthelpproject.html#filter-attributes). +# https://doc.qt.io/archives/qt-4.8/qthelpproject.html#filter-attributes). # This tag requires that the tag GENERATE_QHP is set to YES. QHP_SECT_FILTER_ATTRS = -# The QHG_LOCATION tag can be used to specify the location of Qt's -# qhelpgenerator. If non-empty doxygen will try to run qhelpgenerator on the -# generated .qhp file. +# The QHG_LOCATION tag can be used to specify the location (absolute path +# including file name) of Qt's qhelpgenerator. If non-empty doxygen will try to +# run qhelpgenerator on the generated .qhp file. # This tag requires that the tag GENERATE_QHP is set to YES. QHG_LOCATION = @@ -1462,6 +1533,17 @@ TREEVIEW_WIDTH = 250 EXT_LINKS_IN_WINDOW = NO +# If the HTML_FORMULA_FORMAT option is set to svg, doxygen will use the pdf2svg +# tool (see https://github.com/dawbarton/pdf2svg) or inkscape (see +# https://inkscape.org) to generate formulas as SVG images instead of PNGs for +# the HTML output. These images will generally look nicer at scaled resolutions. +# Possible values are: png (the default) and svg (looks nicer but requires the +# pdf2svg or inkscape tool). +# The default value is: png. +# This tag requires that the tag GENERATE_HTML is set to YES. + +HTML_FORMULA_FORMAT = png + # Use this tag to change the font size of LaTeX formulas included as images in # the HTML documentation. When you change the font size after a successful # doxygen run you need to manually remove any form_*.png images from the HTML @@ -1471,7 +1553,7 @@ EXT_LINKS_IN_WINDOW = NO FORMULA_FONTSIZE = 10 -# Use the FORMULA_TRANPARENT tag to determine whether or not the images +# Use the FORMULA_TRANSPARENT tag to determine whether or not the images # generated for formulas are transparent PNGs. Transparent PNGs are not # supported properly for IE 6.0, but are supported on all modern browsers. # @@ -1482,8 +1564,14 @@ FORMULA_FONTSIZE = 10 FORMULA_TRANSPARENT = YES +# The FORMULA_MACROFILE can contain LaTeX \newcommand and \renewcommand commands +# to create new LaTeX commands to be used in formulas as building blocks. See +# the section "Including formulas" for details. + +FORMULA_MACROFILE = + # Enable the USE_MATHJAX option to render LaTeX formulas using MathJax (see -# http://www.mathjax.org) which uses client side Javascript for the rendering +# https://www.mathjax.org) which uses client side JavaScript for the rendering # instead of using pre-rendered bitmaps. Use this if you do not have LaTeX # installed or if you want to formulas look prettier in the HTML output. When # enabled you may also need to install MathJax separately and configure the path @@ -1495,7 +1583,7 @@ USE_MATHJAX = NO # When MathJax is enabled you can set the default output format to be used for # the MathJax output. See the MathJax site (see: -# http://docs.mathjax.org/en/latest/output.html) for more details. +# http://docs.mathjax.org/en/v2.7-latest/output.html) for more details. # Possible values are: HTML-CSS (which is slower, but has the best # compatibility), NativeMML (i.e. MathML) and SVG. # The default value is: HTML-CSS. @@ -1510,8 +1598,8 @@ MATHJAX_FORMAT = HTML-CSS # MATHJAX_RELPATH should be ../mathjax. The default value points to the MathJax # Content Delivery Network so you can quickly see the result without installing # MathJax. However, it is strongly recommended to install a local copy of -# MathJax from http://www.mathjax.org before deployment. -# The default value is: http://cdn.mathjax.org/mathjax/latest. +# MathJax from https://www.mathjax.org before deployment. +# The default value is: https://cdn.jsdelivr.net/npm/mathjax@2. # This tag requires that the tag USE_MATHJAX is set to YES. MATHJAX_RELPATH = http://www.mathjax.org/mathjax @@ -1525,7 +1613,8 @@ MATHJAX_EXTENSIONS = # The MATHJAX_CODEFILE tag can be used to specify a file with javascript pieces # of code that will be used on startup of the MathJax code. See the MathJax site -# (see: http://docs.mathjax.org/en/latest/output.html) for more details. For an +# (see: +# http://docs.mathjax.org/en/v2.7-latest/output.html) for more details. For an # example see the documentation. # This tag requires that the tag USE_MATHJAX is set to YES. @@ -1553,7 +1642,7 @@ MATHJAX_CODEFILE = SEARCHENGINE = YES # When the SERVER_BASED_SEARCH tag is enabled the search engine will be -# implemented using a web server instead of a web client using Javascript. There +# implemented using a web server instead of a web client using JavaScript. There # are two flavors of web server based searching depending on the EXTERNAL_SEARCH # setting. When disabled, doxygen will generate a PHP script for searching and # an index file used by the script. When EXTERNAL_SEARCH is enabled the indexing @@ -1572,7 +1661,8 @@ SERVER_BASED_SEARCH = NO # # Doxygen ships with an example indexer (doxyindexer) and search engine # (doxysearch.cgi) which are based on the open source search engine library -# Xapian (see: http://xapian.org/). +# Xapian (see: +# https://xapian.org/). # # See the section "External Indexing and Searching" for details. # The default value is: NO. @@ -1585,8 +1675,9 @@ EXTERNAL_SEARCH = NO # # Doxygen ships with an example indexer (doxyindexer) and search engine # (doxysearch.cgi) which are based on the open source search engine library -# Xapian (see: http://xapian.org/). See the section "External Indexing and -# Searching" for details. +# Xapian (see: +# https://xapian.org/). See the section "External Indexing and Searching" for +# details. # This tag requires that the tag SEARCHENGINE is set to YES. SEARCHENGINE_URL = @@ -1637,21 +1728,35 @@ LATEX_OUTPUT = latex # The LATEX_CMD_NAME tag can be used to specify the LaTeX command name to be # invoked. # -# Note that when enabling USE_PDFLATEX this option is only used for generating -# bitmaps for formulas in the HTML output, but not in the Makefile that is -# written to the output directory. -# The default file is: latex. +# Note that when not enabling USE_PDFLATEX the default is latex when enabling +# USE_PDFLATEX the default is pdflatex and when in the later case latex is +# chosen this is overwritten by pdflatex. For specific output languages the +# default can have been set differently, this depends on the implementation of +# the output language. # This tag requires that the tag GENERATE_LATEX is set to YES. LATEX_CMD_NAME = latex # The MAKEINDEX_CMD_NAME tag can be used to specify the command name to generate # index for LaTeX. +# Note: This tag is used in the Makefile / make.bat. +# See also: LATEX_MAKEINDEX_CMD for the part in the generated output file +# (.tex). # The default file is: makeindex. # This tag requires that the tag GENERATE_LATEX is set to YES. MAKEINDEX_CMD_NAME = makeindex +# The LATEX_MAKEINDEX_CMD tag can be used to specify the command name to +# generate index for LaTeX. In case there is no backslash (\) as first character +# it will be automatically added in the LaTeX code. +# Note: This tag is used in the generated output file (.tex). +# See also: MAKEINDEX_CMD_NAME for the part in the Makefile / make.bat. +# The default value is: makeindex. +# This tag requires that the tag GENERATE_LATEX is set to YES. + +LATEX_MAKEINDEX_CMD = makeindex + # If the COMPACT_LATEX tag is set to YES, doxygen generates more compact LaTeX # documents. This may be useful for small projects and may help to save some # trees in general. @@ -1736,9 +1841,11 @@ LATEX_EXTRA_FILES = PDF_HYPERLINKS = YES -# If the USE_PDFLATEX tag is set to YES, doxygen will use pdflatex to generate -# the PDF file directly from the LaTeX files. Set this option to YES, to get a -# higher quality PDF documentation. +# If the USE_PDFLATEX tag is set to YES, doxygen will use the engine as +# specified with LATEX_CMD_NAME to generate the PDF file directly from the LaTeX +# files. Set this option to YES, to get a higher quality PDF documentation. +# +# See also section LATEX_CMD_NAME for selecting the engine. # The default value is: YES. # This tag requires that the tag GENERATE_LATEX is set to YES. @@ -1772,12 +1879,28 @@ LATEX_SOURCE_CODE = NO # The LATEX_BIB_STYLE tag can be used to specify the style to use for the # bibliography, e.g. plainnat, or ieeetr. See -# http://en.wikipedia.org/wiki/BibTeX and \cite for more info. +# https://en.wikipedia.org/wiki/BibTeX and \cite for more info. # The default value is: plain. # This tag requires that the tag GENERATE_LATEX is set to YES. LATEX_BIB_STYLE = plain +# If the LATEX_TIMESTAMP tag is set to YES then the footer of each generated +# page will contain the date and time when the page was generated. Setting this +# to NO can help when comparing the output of multiple runs. +# The default value is: NO. +# This tag requires that the tag GENERATE_LATEX is set to YES. + +LATEX_TIMESTAMP = NO + +# The LATEX_EMOJI_DIRECTORY tag is used to specify the (relative or absolute) +# path from which the emoji images will be read. If a relative path is entered, +# it will be relative to the LATEX_OUTPUT directory. If left blank the +# LATEX_OUTPUT directory will be used. +# This tag requires that the tag GENERATE_LATEX is set to YES. + +LATEX_EMOJI_DIRECTORY = + #--------------------------------------------------------------------------- # Configuration options related to the RTF output #--------------------------------------------------------------------------- @@ -1817,9 +1940,9 @@ COMPACT_RTF = NO RTF_HYPERLINKS = YES -# Load stylesheet definitions from file. Syntax is similar to doxygen's config -# file, i.e. a series of assignments. You only have to provide replacements, -# missing definitions are set to their default value. +# Load stylesheet definitions from file. Syntax is similar to doxygen's +# configuration file, i.e. a series of assignments. You only have to provide +# replacements, missing definitions are set to their default value. # # See also section "Doxygen usage" for information on how to generate the # default style sheet that doxygen normally uses. @@ -1828,8 +1951,8 @@ RTF_HYPERLINKS = YES RTF_STYLESHEET_FILE = # Set optional variables used in the generation of an RTF document. Syntax is -# similar to doxygen's config file. A template extensions file can be generated -# using doxygen -e rtf extensionFile. +# similar to doxygen's configuration file. A template extensions file can be +# generated using doxygen -e rtf extensionFile. # This tag requires that the tag GENERATE_RTF is set to YES. RTF_EXTENSIONS_FILE = @@ -1915,6 +2038,13 @@ XML_OUTPUT = xml XML_PROGRAMLISTING = YES +# If the XML_NS_MEMB_FILE_SCOPE tag is set to YES, doxygen will include +# namespace members in file scope as well, matching the HTML output. +# The default value is: NO. +# This tag requires that the tag GENERATE_XML is set to YES. + +XML_NS_MEMB_FILE_SCOPE = NO + #--------------------------------------------------------------------------- # Configuration options related to the DOCBOOK output #--------------------------------------------------------------------------- @@ -1947,9 +2077,9 @@ DOCBOOK_PROGRAMLISTING = NO #--------------------------------------------------------------------------- # If the GENERATE_AUTOGEN_DEF tag is set to YES, doxygen will generate an -# AutoGen Definitions (see http://autogen.sf.net) file that captures the -# structure of the code including all documentation. Note that this feature is -# still experimental and incomplete at the moment. +# AutoGen Definitions (see http://autogen.sourceforge.net/) file that captures +# the structure of the code including all documentation. Note that this feature +# is still experimental and incomplete at the moment. # The default value is: NO. GENERATE_AUTOGEN_DEF = NO @@ -2116,12 +2246,6 @@ EXTERNAL_GROUPS = YES EXTERNAL_PAGES = YES -# The PERL_PATH should be the absolute path and name of the perl script -# interpreter (i.e. the result of 'which perl'). -# The default file (with absolute path) is: /usr/bin/perl. - -PERL_PATH = /sw/bin/perl - #--------------------------------------------------------------------------- # Configuration options related to the dot tool #--------------------------------------------------------------------------- @@ -2135,15 +2259,6 @@ PERL_PATH = /sw/bin/perl CLASS_DIAGRAMS = YES -# You can define message sequence charts within doxygen comments using the \msc -# command. Doxygen will then run the mscgen tool (see: -# http://www.mcternan.me.uk/mscgen/)) to produce the chart and insert it in the -# documentation. The MSCGEN_PATH tag allows you to specify the directory where -# the mscgen tool resides. If left empty the tool is assumed to be found in the -# default search path. - -MSCGEN_PATH = - # You can include diagrams made with dia in doxygen documentation. Doxygen will # then run dia to produce the diagram and insert it in the documentation. The # DIA_PATH tag allows you to specify the directory where the dia binary resides. @@ -2241,10 +2356,32 @@ UML_LOOK = NO # but if the number exceeds 15, the total amount of fields shown is limited to # 10. # Minimum value: 0, maximum value: 100, default value: 10. -# This tag requires that the tag HAVE_DOT is set to YES. +# This tag requires that the tag UML_LOOK is set to YES. UML_LIMIT_NUM_FIELDS = 10 +# If the DOT_UML_DETAILS tag is set to NO, doxygen will show attributes and +# methods without types and arguments in the UML graphs. If the DOT_UML_DETAILS +# tag is set to YES, doxygen will add type and arguments for attributes and +# methods in the UML graphs. If the DOT_UML_DETAILS tag is set to NONE, doxygen +# will not generate fields with class member information in the UML graphs. The +# class diagrams will look similar to the default class diagrams but using UML +# notation for the relationships. +# Possible values are: NO, YES and NONE. +# The default value is: NO. +# This tag requires that the tag UML_LOOK is set to YES. + +DOT_UML_DETAILS = NO + +# The DOT_WRAP_THRESHOLD tag can be used to set the maximum number of characters +# to display on a single line. If the actual line length exceeds this threshold +# significantly it will wrapped across multiple lines. Some heuristics are apply +# to avoid ugly line breaks. +# Minimum value: 0, maximum value: 1000, default value: 17. +# This tag requires that the tag HAVE_DOT is set to YES. + +DOT_WRAP_THRESHOLD = 17 + # If the TEMPLATE_RELATIONS tag is set to YES then the inheritance and # collaboration graphs will show the relations between templates and their # instances. @@ -2371,6 +2508,11 @@ DIAFILE_DIRS = PLANTUML_JAR_PATH = +# When using plantuml, the PLANTUML_CFG_FILE tag can be used to specify a +# configuration file for plantuml. + +PLANTUML_CFG_FILE = + # When using plantuml, the specified paths are searched for files specified by # the !include statement in a plantuml block. @@ -2429,9 +2571,11 @@ DOT_MULTI_TARGETS = NO GENERATE_LEGEND = YES -# If the DOT_CLEANUP tag is set to YES, doxygen will remove the intermediate dot +# If the DOT_CLEANUP tag is set to YES, doxygen will remove the intermediate # files that are used to generate the various graphs. +# +# Note: This setting is not only used for dot files but also for msc and +# plantuml temporary files. # The default value is: YES. -# This tag requires that the tag HAVE_DOT is set to YES. DOT_CLEANUP = YES diff --git a/lapack-netlib/DOCS/DoxygenLayout.xml b/lapack-netlib/DOCS/DoxygenLayout.xml new file mode 100644 index 000000000..aeb346d8d --- /dev/null +++ b/lapack-netlib/DOCS/DoxygenLayout.xml @@ -0,0 +1,197 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/lapack-netlib/DOCS/groups-usr.dox b/lapack-netlib/DOCS/groups-usr.dox index 6c31e4cf5..cbd747165 100644 --- a/lapack-netlib/DOCS/groups-usr.dox +++ b/lapack-netlib/DOCS/groups-usr.dox @@ -1,605 +1,974 @@ /** - * - **** - * - * @defgroup lapack LAPACK - * This is the group of LAPACK routines. - * - * @defgroup GE General Matrices - * @ingroup lapack - * This is the group of General Matrices routines - * @defgroup GB General Band Matrix - * @ingroup lapack - * This is the group of General Band routines - * @defgroup SY Symmetric Matrix - * @ingroup lapack - * This is the group of Symmetric Matrix routines - * @defgroup HE Hermitian Matrix - * @ingroup lapack - * This is the group of Hermitian Matrix routines - * @defgroup PO Positive Definite Matrix - * @ingroup lapack - * This is the group of Positive Definite routines - * @defgroup GT General tridiagonal Matrix - * @ingroup lapack - * This is the group of General tridiagonal routines - * @defgroup PT Positive Definite tridiagonal Matrix - * @ingroup lapack - * This is the group of Positive Definite tridiagonal routines - * @defgroup OTHEReigen Eigenvalue - * @ingroup lapack - * This is the group of Other Eigenvalue routines - * @defgroup OTHERauxiliary Other Auxiliary Routines - * @ingroup lapack - * This is the group of Other Auxiliary routines - * @defgroup OTHERcomputational Other Computational Routines - * @ingroup lapack - * This is the group of Other Computational routines - * @defgroup OTHERsolve Other Solve Routines - * @ingroup lapack - * This is the group of Other Solve routines - * - **** - * - * @defgroup solveGE Linear Solve - * @ingroup GE - * This is the group of Linear Solve Driver routines - * @defgroup solveGB Linear Solve - * @ingroup GB - * This is the group of Linear Solve Driver routines - * @defgroup solveSY Linear Solve - * @ingroup SY - * This is the group of Linear Solve Driver routines - * @defgroup solveHE Linear Solve - * @ingroup HE - * This is the group of Linear Solve Driver routines - * @defgroup solvePO Linear Solve - * @ingroup PO - * This is the group of Linear Solve Driver routines - * @defgroup solveGT Linear Solve - * @ingroup GT - * This is the group of Linear Solve Driver routines - * @defgroup solvePT Linear Solve - * @ingroup PT - * This is the group of Linear Solve Driver routines - * @defgroup eigenGE Eigenvalue - * @ingroup GE - * This is the group of Eigenvalue Driver routines - * @defgroup eigenSY Eigenvalue - * @ingroup SY - * This is the group of Eigenvalue Driver routines - * @defgroup eigenHE Eigenvalue - * @ingroup HE - * This is the group of Eigenvalue Driver routines - * @defgroup singGE Singular Value - * @ingroup GE - * This is the group of Singular Value Driver routines - * @defgroup computationalGE Computational routines - * @ingroup GE - * This is the group of Computational routines - * @defgroup variantsGEcomputational Variants Computational routines - * @ingroup GE - * This is the group of Variants Computational routines - * @defgroup computationalGB Computational routines - * @ingroup GB - * This is the group of Computational routines - * @defgroup computationalSY Computational routines - * @ingroup SY - * This is the group of Computational routines - * @defgroup computationalHE Computational routines - * @ingroup HE - * This is the group of Computational routines - * @defgroup computationalPO Computational routines - * @ingroup PO - * This is the group of Computational routines - * @defgroup variantsPOcomputational Variants Computational routines - * @ingroup PO - * This is the group of Variants Computational routines - * @defgroup computationalGT Computational routines - * @ingroup GT - * This is the group of Computational routines - * @defgroup computationalPT Computational routines - * @ingroup PT - * This is the group of Computational routines - * @defgroup variantsOTHERcomputational Variants Computational routines - * @ingroup OTHERcomputational - * This is the group of Variants Computational routines - * @defgroup auxiliaryGE Auxiliary routines - * @ingroup GE - * This is the group of Auxiliary routines - * @defgroup auxiliaryGB Auxiliary routines - * @ingroup GB - * This is the group of Auxiliary routines - * @defgroup auxiliarySY Auxiliary routines - * @ingroup SY - * This is the group of Auxiliary routines - * @defgroup auxiliaryHE Auxiliary routines - * @ingroup HE - * This is the group of Auxiliary routines - * @defgroup auxiliaryPO Auxiliary routines - * @ingroup PO - * This is the group of Auxiliary routines - * @defgroup auxiliaryGT Auxiliary routines - * @ingroup GT - * This is the group of Auxiliary routines - * @defgroup auxiliaryPT Auxiliary routines - * @ingroup PT - * This is the group of Auxiliary routines - * - **** - * - * @defgroup doubleGEsolve double - * @ingroup solveGE - * This is the group of double solve driver functions for GE matrices - * @defgroup doublePOsolve double - * @ingroup solvePO - * This is the group of double solve driver functions for PO matrices - * @defgroup doubleSYsolve double - * @ingroup solveSY - * This is the group of double solve driver functions for SY matrices - * @defgroup doubleGBsolve double - * @ingroup solveGB - * This is the group of double solve driver functions for GB matrices - * @defgroup doubleGTsolve double - * @ingroup solveGT - * This is the group of double solve driver functions for GT matrices - * @defgroup doublePTsolve double - * @ingroup solvePT - * This is the group of double solve driver functions for PT matrices - * @defgroup doubleGEeigen double - * @ingroup eigenGE - * This is the group of double eigenvalue driver functions for GE matrices - * @defgroup doubleSYeigen double - * @ingroup eigenSY - * This is the group of double eigenvalue driver functions for SY matrices - * @defgroup doubleGEsing double - * @ingroup singGE - * This is the group of double singular value driver functions for GE matrices - * @defgroup doubleGEcomputational double - * @ingroup computationalGE - * This is the group of double computational functions for GE matrices - * @defgroup doublePOcomputational double - * @ingroup computationalPO - * This is the group of double computational functions for PO matrices - * @defgroup doubleSYcomputational double - * @ingroup computationalSY - * This is the group of double computational functions for SY matrices - * @defgroup doubleGBcomputational double - * @ingroup computationalGB - * This is the group of double computational functions for GB matrices - * @defgroup doubleGTcomputational double - * @ingroup computationalGT - * This is the group of double computational functions for GT matrices - * @defgroup doublePTcomputational double - * @ingroup computationalPT - * This is the group of double computational functions for PT matrices - * @defgroup doubleGEauxiliary double - * @ingroup auxiliaryGE - * This is the group of double auxiliary functions for GE matrices - * @defgroup doublePOauxiliary double - * @ingroup auxiliaryPO - * This is the group of double auxiliary functions for PO matrices - * @defgroup doubleSYauxiliary double - * @ingroup auxiliarySY - * This is the group of double auxiliary functions for SY matrices - * @defgroup doubleGBauxiliary double - * @ingroup auxiliaryGB - * This is the group of double auxiliary functions for GB matrices - * @defgroup doublePTauxiliary double - * @ingroup auxiliaryPT - * This is the group of double auxiliary functions for PT matrices - * @defgroup doubleGTauxiliary double - * @ingroup auxiliaryGT - * This is the group of double auxiliary functions for GT matrices - * @defgroup doubleOTHERauxiliary double - * @ingroup OTHERauxiliary - * This is the group of double other auxiliary routines - * @defgroup doubleOTHERcomputational double - * @ingroup OTHERcomputational - * This is the group of double other Computational routines - * @defgroup doubleOTHERsolve double Other Solve Routines - * @ingroup OTHERsolve - * This is the group of double Other Solve routines - * @defgroup doubleOTHEReigen double - * @ingroup OTHEReigen - * This is the group of double Other Eigenvalue routines - * - **** - * - * @defgroup realGEsolve real - * @ingroup solveGE - * This is the group of real solve driver functions for GE matrices - * @defgroup realPOsolve real - * @ingroup solvePO - * This is the group of real solve driver functions for PO matrices - * @defgroup realSYsolve real - * @ingroup solveSY - * This is the group of real solve driver functions for SY matrices - * @defgroup realGBsolve real - * @ingroup solveGB - * This is the group of real solve driver functions for GB matrices - * @defgroup realGTsolve real - * @ingroup solveGT - * This is the group of real solve driver functions for GT matrices - * @defgroup realPTsolve real - * @ingroup solvePT - * This is the group of real solve driver functions for PT matrices - * @defgroup realGEeigen real - * @ingroup eigenGE - * This is the group of real eigenvalue driver functions for GE matrices - * @defgroup realSYeigen real - * @ingroup eigenSY - * This is the group of real eigenvalue driver functions for SY matrices - * @defgroup realGEsing real - * @ingroup singGE - * This is the group of real singular value driver functions for GE matrices - * @defgroup realGEcomputational real - * @ingroup computationalGE - * This is the group of real computational functions for GE matrices - * @defgroup realPOcomputational real - * @ingroup computationalPO - * This is the group of real computational functions for PO matrices - * @defgroup realSYcomputational real - * @ingroup computationalSY - * This is the group of real computational functions for SY matrices - * @defgroup realGBcomputational real - * @ingroup computationalGB - * This is the group of real computational functions for GB matrices - * @defgroup realPTcomputational real - * @ingroup computationalPT - * This is the group of real computational functions for PT matrices - * @defgroup realGTcomputational real - * @ingroup computationalGT - * This is the group of real computational functions for GT matrices - * @defgroup realGEauxiliary real - * @ingroup auxiliaryGE - * This is the group of real auxiliary functions for GE matrices - * @defgroup realPOauxiliary real - * @ingroup auxiliaryPO - * This is the group of real auxiliary functions for PO matrices - * @defgroup realSYauxiliary real - * @ingroup auxiliarySY - * This is the group of real auxiliary functions for SY matrices - * @defgroup realGBauxiliary real - * @ingroup auxiliaryGB - * This is the group of real auxiliary functions for GB matrices - * @defgroup realGTauxiliary real - * @ingroup auxiliaryGT - * This is the group of real auxiliary functions for GT matrices - * @defgroup realPTauxiliary real - * @ingroup auxiliaryPT - * This is the group of real auxiliary functions for PT matrices - * @defgroup realOTHERauxiliary real - * @ingroup OTHERauxiliary - * This is the group of real other auxiliary routines - * @defgroup realOTHERcomputational real - * @ingroup OTHERcomputational - * This is the group of real other Computational routines - * @defgroup realOTHERsolve real Other Solve Routines - * @ingroup OTHERsolve - * This is the group of real Other Solve routines - * @defgroup realOTHEReigen real - * @ingroup OTHEReigen - * This is the group of real Other Eigenvalue routines - * - **** - * - * @defgroup complexGEsolve complex - * @ingroup solveGE - * This is the group of complex solve driver functions for GE matrices - * @defgroup complexPOsolve complex - * @ingroup solvePO - * This is the group of complex solve driver functions for PO matrices - * @defgroup complexSYsolve complex - * @ingroup solveSY - * This is the group of complex solve driver functions for SY matrices - * @defgroup complexHEsolve complex - * @ingroup solveHE - * This is the group of complex solve driver functions for HE matrices - * @defgroup complexGBsolve complex - * @ingroup solveGB - * This is the group of complex solve driver functions for GB matrices - * @defgroup complexGTsolve complex - * @ingroup solveGT - * This is the group of complex solve driver functions for GT matrices - * @defgroup complexPTsolve complex - * @ingroup solvePT - * This is the group of complex solve driver functions for PT matrices - * @defgroup complexGEeigen complex - * @ingroup eigenGE - * This is the group of complex eigenvalue driver functions for GE matrices - * @defgroup complexSYeigen complex - * @ingroup eigenSY - * This is the group of complex eigenvalue driver functions for SY matrices - * @defgroup complexHEeigen complex - * @ingroup eigenHE - * This is the group of complex eigenvalue driver functions for HE matrices - * @defgroup complexGEsing complex - * @ingroup singGE - * This is the group of complex singular value driver functions for GE matrices - * @defgroup complexGEcomputational complex - * @ingroup computationalGE - * This is the group of complex computational functions for GE matrices - * @defgroup complexPOcomputational complex - * @ingroup computationalPO - * This is the group of complex computational functions for PO matrices - * @defgroup complexSYcomputational complex - * @ingroup computationalSY - * This is the group of complex computational functions for SY matrices - * @defgroup complexHEcomputational complex - * @ingroup computationalHE - * This is the group of complex computational functions for HE matrices - * @defgroup complexGBcomputational complex - * @ingroup computationalGB - * This is the group of complex computational functions for GB matrices - * @defgroup complexGTcomputational complex - * @ingroup computationalGT - * This is the group of complex computational functions for GT matrices - * @defgroup complexPTcomputational complex - * @ingroup computationalPT - * This is the group of complex computational functions for PT matrices - * @defgroup complexGEauxiliary complex - * @ingroup auxiliaryGE - * This is the group of complex auxiliary functions for GE matrices - * @defgroup complexPOauxiliary complex - * @ingroup auxiliaryPO - * This is the group of complex auxiliary functions for PO matrices - * @defgroup complexSYauxiliary complex - * @ingroup auxiliarySY - * This is the group of complex auxiliary functions for SY matrices - * @defgroup complexHEauxiliary complex - * @ingroup auxiliaryHE - * This is the group of complex auxiliary functions for HE matrices - * @defgroup complexGBauxiliary complex - * @ingroup auxiliaryGB - * This is the group of complex auxiliary functions for GB matrices - * @defgroup complexOTHERauxiliary complex - * @ingroup OTHERauxiliary - * This is the group of complex other auxiliary routines - * @defgroup complexOTHERcomputational complex - * @ingroup OTHERcomputational - * This is the group of complex other Computational routines - * @defgroup complexOTHERsolve complex Other Solve Routines - * @ingroup OTHERsolve - * This is the group of complex Other Solve routines - * @defgroup complexOTHEReigen complex Other Eigenvalue routines - * @ingroup OTHEReigen - * This is the group of complex Other Eigenvalue routines - * - **** - * - * @defgroup complex16GEsolve complex16 - * @ingroup solveGE - * This is the group of complex16 solve driver functions for GE matrices - * @defgroup complex16POsolve complex16 - * @ingroup solvePO - * This is the group of complex16 solve driver functions for PO matrices - * @defgroup complex16SYsolve complex16 - * @ingroup solveSY - * This is the group of complex16 solve driver functions for SY matrices - * @defgroup complex16HEsolve complex16 - * @ingroup solveHE - * This is the group of complex16 solve driver functions for HE matrices - * @defgroup complex16GBsolve complex16 - * @ingroup solveGB - * This is the group of complex16 solve driver functions for GB matrices - * @defgroup complex16GTsolve complex16 - * @ingroup solveGT - * This is the group of complex16 solve driver functions for GT matrices - * @defgroup complex16PTsolve complex16 - * @ingroup solvePT - * This is the group of complex16 solve driver functions for PT matrices - * @defgroup complex16GEeigen complex16 - * @ingroup eigenGE - * This is the group of complex16 eigenvalue driver functions for GE matrices - * @defgroup complex16SYeigen complex16 - * @ingroup eigenSY - * This is the group of complex16 eigenvalue driver functions for SY matrices - * @defgroup complex16HEeigen complex16 - * @ingroup eigenHE - * This is the group of complex16 eigenvalue driver functions for HE matrices - * @defgroup complex16GEsing complex16 - * @ingroup singGE - * This is the group of complex16 singular value driver functions for GE matrices - * @defgroup complex16GEcomputational complex16 - * @ingroup computationalGE - * This is the group of complex16 computational functions for GE matrices - * @defgroup complex16POcomputational complex16 - * @ingroup computationalPO - * This is the group of complex16 computational functions for PO matrices - * @defgroup complex16SYcomputational complex16 - * @ingroup computationalSY - * This is the group of complex16 computational functions for SY matrices - * @defgroup complex16HEcomputational complex16 - * @ingroup computationalHE - * This is the group of complex16 computational functions for HE matrices - * @defgroup complex16GBcomputational complex16 - * @ingroup computationalGB - * This is the group of complex16 computational functions for GB matrices - * @defgroup complex16GTcomputational complex16 - * @ingroup computationalGT - * This is the group of complex16 computational functions for GT matrices - * @defgroup complex16PTcomputational complex16 - * @ingroup computationalPT - * This is the group of complex16 computational functions for PT matrices - * @defgroup complex16GEauxiliary complex16 - * @ingroup auxiliaryGE - * This is the group of complex16 auxiliary functions for GE matrices - * @defgroup complex16POauxiliary complex16 - * @ingroup auxiliaryPO - * This is the group of complex16 auxiliary functions for PO matrices - * @defgroup complex16SYauxiliary complex16 - * @ingroup auxiliarySY - * This is the group of complex16 auxiliary functions for SY matrices - * @defgroup complex16HEauxiliary complex16 - * @ingroup auxiliaryHE - * This is the group of complex16 auxiliary functions for HE matrices - * @defgroup complex16GBauxiliary complex16 - * @ingroup auxiliaryGB - * This is the group of complex16 auxiliary functions for GB matrices - * @defgroup complex16OTHERcomputational complex16 - * @ingroup OTHERcomputational - * This is the group of complex16 other Computational routines - * @defgroup complex16OTHERauxiliary complex16 - * @ingroup OTHERauxiliary - * This is the group of complex16 other auxiliary routines - * @defgroup auxOTHERcomputational auxiliary Computational routines - * @ingroup OTHERcomputational - * This is the group of auxiliary Computational routines - * @defgroup complex16OTHERsolve complex16 Other Solve Routines - * @ingroup OTHERsolve - * This is the group of complex16 Other Solve routines - * @defgroup complex16OTHEReigen complex16 Other Eigenvalue routines - * @ingroup OTHEReigen - * This is the group of complex16 Other Eigenvalue routines - * - **** - * - * @defgroup testing LAPACK Testing - * This is the group of LAPACK TESTING routines. - * - * @defgroup matgen Matrix Generation - * @ingroup testing - * This is the group of LAPACK TESTING MATGEN routines. - * - * @defgroup lin Linear Solve - * @ingroup testing - * This is the group of LAPACK TESTING LIN routines. - * - * @defgroup eig Eigenvalue and Singular value - * @ingroup testing - * This is the group of LAPACK TESTING EIG routines. - * - * @defgroup real_matgen real - * @ingroup matgen - * This is the group of real LAPACK TESTING MATGEN routines. - * - * @defgroup double_matgen double - * @ingroup matgen - * This is the group of double LAPACK TESTING MATGEN routines. - * - * @defgroup complex_matgen complex - * @ingroup matgen - * This is the group of complex LAPACK TESTING MATGEN routines. - * - * @defgroup complex16_matgen complex16 - * @ingroup matgen - * This is the group of complex16 LAPACK TESTING MATGEN routines. - * - * @defgroup aux_matgen aux - * @ingroup matgen - * This is the group of auxiliary LAPACK TESTING MATGEN routines. - * - * @defgroup single_lin real - * @ingroup lin - * This is the group of real LAPACK TESTING LIN routines. - * - * @defgroup double_lin double - * @ingroup lin - * This is the group of double LAPACK TESTING LIN routines. - * - * @defgroup complex_lin complex - * @ingroup lin - * This is the group of complex LAPACK TESTING LIN routines. - * - * @defgroup complex16_lin complex16 - * @ingroup lin - * This is the group of complex16 LAPACK TESTING LIN routines. - * - * @defgroup aux_lin aux - * @ingroup lin - * This is the group of auxiliary LAPACK TESTING LIN routines. - * - * @defgroup single_eig real - * @ingroup eig - * This is the group of real LAPACK TESTING EIG routines. - * - * @defgroup double_eig double - * @ingroup eig - * This is the group of double LAPACK TESTING EIG routines. - * - * @defgroup complex_eig complex - * @ingroup eig - * This is the group of complex LAPACK TESTING EIG routines. - * - * @defgroup complex16_eig complex16 - * @ingroup eig - * This is the group of complex16 LAPACK TESTING EIG routines. - * - * @defgroup aux_eig aux - * @ingroup eig - * This is the group of auxiliary LAPACK TESTING EIG routines. - * - **** - * @defgroup blas Reference BLAS - * This is the group of BLAS routines. - * - * @defgroup level1 Level1 - * @ingroup blas - * This is the group of LEVEL 1 BLAS routines. - * @defgroup level2 Level2 - * @ingroup blas - * This is the group of LEVEL 2 BLAS routines. - * @defgroup level3 Level3 - * @ingroup blas - * This is the group of LEVEL 3 BLAS routines. - * @defgroup aux_blas Auxiliary BLAS - * @ingroup blas - * This is the group of Auxiliary 3 BLAS routines. -* @defgroup blastesting Testing - * @ingroup blas - * This is the group of BLAS TESTING routines. - * - * @defgroup single_blas_level1 real - * @ingroup level1 - * This is the group of real LEVEL 1 BLAS routines. - * @defgroup double_blas_level1 double - * @ingroup level1 - * This is the group of double LEVEL 1 BLAS routines. - * @defgroup complex_blas_level1 complex - * @ingroup level1 - * This is the group of complex LEVEL 1 BLAS routines. - * @defgroup complex16_blas_level1 complex16 - * @ingroup level1 - * This is the group of complex16 LEVEL 1 BLAS routines. - * - * @defgroup single_blas_level2 real - * @ingroup level2 - * This is the group of real LEVEL 2 BLAS routines. - * @defgroup double_blas_level2 double - * @ingroup level2 - * This is the group of double LEVEL 2 BLAS routines. - * @defgroup complex_blas_level2 complex - * @ingroup level2 - * This is the group of complex LEVEL 2 BLAS routines. - * @defgroup complex16_blas_level2 complex16 - * @ingroup level2 - * This is the group of complex16 LEVEL 2 BLAS routines. - * - * @defgroup single_blas_level3 real - * @ingroup level3 - * This is the group of real LEVEL 3 BLAS routines. - * @defgroup double_blas_level3 double - * @ingroup level3 - * This is the group of double LEVEL 3 BLAS routines. - * @defgroup complex_blas_level3 complex - * @ingroup level3 - * This is the group of complex LEVEL 3 BLAS routines. - * @defgroup complex16_blas_level3 complex16 - * @ingroup level3 - * This is the group of complex16 LEVEL 3 BLAS routines. - * - * @defgroup single_blas_testing real - * @ingroup blastesting - * This is the group of real BLAS TESTING routines. - * @defgroup double_blas_testing double - * @ingroup blastesting - * This is the group of double BLAS TESTING routines. - * @defgroup complex_blas_testing complex - * @ingroup blastesting - * This is the group of complex BLAS TESTING routines. - * @defgroup complex16_blas_testing complex16 - * @ingroup blastesting - * This is the group of complex16 BLAS TESTING routines. - * + +@defgroup lapack_top LAPACK +@{ + @defgroup solve_top Linear solve, AX = B + @{ + @defgroup gesv_driver_grp LU: General matrix, driver + @{ + @defgroup gesv_driver --- full --- + @defgroup gesv gesv: factor and solve + @defgroup gesvx gesvx: factor and solve, expert + @defgroup gesvxx gesvxx: factor and solve, extra precise + @defgroup gesv_mixed gesv: factor and solve, mixed precision + + @defgroup gbsv_driver --- banded --- + @defgroup gbsv gbsv: factor and solve + @defgroup gbsvx gbsvx: factor and solve, expert + @defgroup gbsvxx gbsvxx: factor and solve, extra precise + + @defgroup gtsv_driver --- tridiagonal --- + @defgroup gtsv gtsv: factor and solve + @defgroup gtsvx gtsvx: factor and solve, expert + @} + + @defgroup gesv_comp_grp LU: computational routines (factor, cond, etc.) + @{ + @defgroup gesv_comp --- full --- + @defgroup gecon gecon: condition number estimate + @defgroup getrf getrf: triangular factor + @defgroup getrf2 getrf2: triangular factor panel, recursive? + @defgroup getf2 getf2: triangular factor panel, level 2 + @defgroup getrs getrs: triangular solve using factor + @defgroup getri getri: triangular inverse + @defgroup gerfs gerfs: iterative refinement + @defgroup gerfsx gerfsx: iterative refinement, expert + @defgroup geequ geequ: equilibration + @defgroup geequb geequb: equilibration, power of 2 + @defgroup laqge laqge: row/col scale matrix + @defgroup laswp laswp: swap permutation + + @defgroup getc2 getc2: triangular factor, with complete pivoting + @defgroup gesc2 gesc2: triangular solve using factor, with complete pivoting + @defgroup latdf latdf: Dif-estimate with complete pivoting LU, step in tgsen + + @defgroup la_gercond la_gercond: Skeel condition number estimate + @defgroup la_gerpvgrw la_gerpvgrw: reciprocal pivot growth + @defgroup la_gerfsx_extended la_gerfsx_extended: step in gerfsx + + @defgroup gbsv_comp --- banded --- + @defgroup gbcon gbcon: condition number estimate + @defgroup gbtrf gbtrf: triangular factor + @defgroup gbtf2 gbtf2: triangular factor, level 2 + @defgroup gbtrs gbtrs: triangular solve using factor + @defgroup gbrfs gbrfs: iterative refinement + @defgroup gbrfsx gbrfsx: iterative refinement, expert + @defgroup gbequ gbequ: equilibration + @defgroup gbequb gbequb: equilibration, power of 2 + @defgroup laqgb laqgb: row/col scale matrix + @defgroup la_gbrcond la_gbrcond: Skeel condition number estimate + @defgroup la_gbrpvgrw la_gbrpvgrw: reciprocal pivot growth + @defgroup la_gbrfsx_extended la_gbrfsx_extended: step in gbrfsx + + @defgroup gtsv_comp --- tridiagonal --- + @defgroup gtcon gtcon: condition number estimate + @defgroup gttrf gttrf: triangular factor + @defgroup gttrs gttrs: triangular solve using factor + @defgroup gtts2 gtts2: triangular solve using factor + @defgroup gtrfs gtrfs: iterative refinement + @} + + @defgroup posv_driver_grp Cholesky: Hermitian/symmetric positive definite matrix, driver + @{ + @defgroup posv_driver --- full --- + @defgroup posv posv: factor and solve + @defgroup posvx posvx: factor and solve, expert + @defgroup posvxx posvxx: factor and solve, extra precise + @defgroup posv_mixed posv: factor and solve, mixed precision + + @defgroup ppsv_driver --- packed --- + @defgroup ppsv ppsv: factor and solve + @defgroup ppsvx ppsvx: factor and solve, expert + + @defgroup pfsv_driver --- rectangular full packed (RFP) --- + @defgroup pfsv pfsv: factor and solve [not available] + + @defgroup pbsv_driver --- banded --- + @defgroup pbsv pbsv: factor and solve + @defgroup pbsvx pbsvx: factor and solve, expert + + @defgroup ptsv_driver --- tridiagonal --- + @defgroup ptsv ptsv: factor and solve + @defgroup ptsvx ptsvx: factor and solve, expert + @} + + @defgroup posv_comp_grp Cholesky: computational routines (factor, cond, etc.) + @{ + @defgroup posv_comp --- full --- + @defgroup pocon pocon: condition number estimate + @defgroup potrf potrf: triangular factor + @defgroup potrf2 potrf2: triangular factor panel, recursive? + @defgroup potf2 potf2: triangular factor panel, level 2 + @defgroup pstrf pstrf: triangular factor, with pivoting + @defgroup pstf2 pstf2: triangular factor, with pivoting panel, level 2 + @defgroup potrs potrs: triangular solve using factor + @defgroup potri potri: triangular inverse + @defgroup porfs porfs: iterative refinement + @defgroup porfsx porfsx: iterative refinement, expert + @defgroup poequ poequ: equilibration + @defgroup poequb poequb: equilibration, power of 2 + @defgroup laqhe laqhe: row/col scale matrix + @defgroup la_porcond la_porcond: Skeel condition number estimate + @defgroup la_porpvgrw la_porpvgrw: reciprocal pivot growth + @defgroup la_porfsx_extended la_porfsx_extended: step in porfsx + + @defgroup ppsv_comp --- packed --- + @defgroup ppcon ppcon: condition number estimate + @defgroup pptrf pptrf: triangular factor + @defgroup pptrs pptrs: triangular solve using factor + @defgroup pptri pptri: triangular inverse + @defgroup pprfs pprfs: iterative refinement + @defgroup ppequ ppequ: equilibration + @defgroup laqhp laqhp: row/col scale matrix + + @defgroup pfsv_comp --- rectangular full packed (RFP) --- + @defgroup pftrf pftrf: triangular factor + @defgroup pftrs pftrs: triangular solve using factor + @defgroup pftri pftri: triangular inverse + + @defgroup pbsv_comp --- banded --- + @defgroup pbcon pbcon: condition number estimate + @defgroup pbtrf pbtrf: triangular factor + @defgroup pbtf2 pbtf2: triangular factor panel, level 2 + @defgroup pbtrs pbtrs: triangular solve using factor + @defgroup pbrfs pbrfs: iterative refinement + @defgroup pbequ pbequ: equilibration + @defgroup laqhb laqhb: row/col scale matrix + + @defgroup ptsv_comp --- tridiagonal --- + @defgroup ptcon ptcon: condition number estimate + @defgroup pttrf pttrf: triangular factor + @defgroup pttrs pttrs: triangular solve using factor + @defgroup ptts2 ptts2: triangular solve using factor, unblocked + @defgroup ptrfs ptrfs: iterative refinement + @} + + @defgroup hesv_driver_grp LDL: Hermitian/symmetric indefinite matrix, driver + @{ + @defgroup hesv_driver --- full, rook pivoting --- + @defgroup hesv {he,sy}sv: rook (v1) + @defgroup hesv_rook {he,sy}sv_rook: rook (v2) + @defgroup hesv_rk {he,sy}sv_rk: rook (v3) + @defgroup hesvx {he,sy}svx: rook (v1, expert) + @defgroup hesvxx {he,sy}svxx: rook (v1, expert) + + @defgroup hpsv_driver --- packed, rook pivoting --- + @defgroup hpsv {hp,sp}sv: factor and solve + @defgroup hpsvx {hp,sp}svx: factor and solve, expert + + @defgroup hesv_aa_driver --- full, Aasen --- + @defgroup hesv_aa {he,sy}sv_aa: Aasen + @defgroup hesv_aa_2stage {he,sy}sv_aa_2stage: Aasen, blocked 2-stage + @} + + @defgroup hesv_comp_grp LDL: computational routines (factor, cond, etc.) + @{ + @defgroup hesv_comp_v1 --- full, rook v1 --- + @defgroup hecon {he,sy}con: condition number estimate + @defgroup hetrf {he,sy}trf: triangular factor + @defgroup lahef la{he,sy}f: step in hetrf + @defgroup hetf2 {he,sy}tf2: triangular factor, level 2 + @defgroup hetrs {he,sy}trs: triangular solve using factor + @defgroup hetri {he,sy}tri: triangular inverse + @defgroup herfs {he,sy}rfs: iterative refinement + @defgroup herfsx {he,sy}rfsx: iterative refinement, expert + @defgroup heequb {he,sy}equb: equilibration, power of 2 + @defgroup syconv syconv: convert to/from L and D from hetrf + + @defgroup hecon_3 {he,sy}con_3: condition number estimate + @defgroup hetri2 {he,sy}tri2: inverse + @defgroup hetri2x {he,sy}tri2x: inverse + @defgroup hetri_3 {he,sy}tri_3: inverse + @defgroup hetri_3x {he,sy}tri_3x: inverse + @defgroup hetrs2 {he,sy}trs2: solve using factor + @defgroup hetrs_3 {he,sy}trs_3: solve using factor + + @defgroup heswapr {he,sy}swapr: apply 2-sided permutation + @defgroup la_hercond la_hercond: Skeel condition number estimate + @defgroup la_herfsx_extended la_herfsx_extended: step in herfsx + @defgroup la_herpvgrw la_herpvgrw: reciprocal pivot growth + + @defgroup hpsv_comp --- packed, rook v1 --- + @defgroup hpcon {hp,sp}con: condition number estimate + @defgroup hptrf {hp,sp}trf: triangular factor + @defgroup hptrs {hp,sp}trs: triangular solve using factor + @defgroup hptri {hp,sp}tri: triangular inverse + @defgroup hprfs {hp,sp}rfs: iterative refinement + + @defgroup hesv_comp_v2 --- full, rook v2 --- + @defgroup hecon_rook {he,sy}con_rook: condition number estimate + @defgroup hetrf_rook {he,sy}trf_rook: triangular factor + @defgroup lahef_rook la{he,sy}f_rook: triangular factor step + @defgroup hetf2_rook {he,sy}tf2_rook: triangular factor, level 2 + @defgroup hetrs_rook {he,sy}trs_rook: triangular solve using factor + @defgroup hetri_rook {he,sy}tri_rook: triangular inverse + + @defgroup hesv_comp_v3 --- full, rook v3 --- + @defgroup hetrf_rk {he,sy}trf_rk: triangular factor + @defgroup lahef_rk la{he,sy}f_rk: triangular factor step + @defgroup hetf2_rk {he,sy}tf2_rk: triangular factor, level 2 + @defgroup syconvf syconvf: convert to/from hetrf to hetrf_rk format + @defgroup syconvf_rook syconvf_rook: convert to/from hetrf_rook to hetrf_rk format + + @defgroup hesv_comp_aasen --- full, Aasen --- + @defgroup hetrf_aa {he,sy}trf_aa: triangular factor + @defgroup lahef_aa la{he,sy}f_aa: triangular factor partial factor + @defgroup hetrs_aa {he,sy}trs_aa: triangular solve using factor + + @defgroup hesv_comp_aasen2 --- full, Aasen, blocked 2-stage --- + @defgroup hetrf_aa_2stage {he,sy}trf_aa_2stage: triangular factor + @defgroup hetrs_aa_2stage {he,sy}trs_aa_2stage: triangular solve using factor + @} + + @defgroup trsv_comp_grp Triangular computational routines (solve, cond, etc.) + @{ + @defgroup trsv_comp --- full --- + @defgroup trcon trcon: condition number estimate + @defgroup trtrs trtrs: triangular solve + @defgroup latrs latrs: triangular solve with robust scaling + @defgroup latrs3 latrs3: triangular solve with robust scaling, level 3 + @defgroup trtri trtri: triangular inverse + @defgroup trti2 trti2: triangular inverse, level 2 + @defgroup trrfs trrfs: triangular iterative refinement + @defgroup lauum lauum: triangular multiply: U^H U + @defgroup lauu2 lauu2: triangular multiply: U^H U, level 2 + + @defgroup tpsv_comp --- packed --- + @defgroup tpcon tpcon: condition number estimate + @defgroup tptrs tptrs: triangular solve + @defgroup latps latps: triangular solve with robust scaling + @defgroup tptri tptri: triangular inverse + @defgroup tprfs tprfs: triangular iterative refinement + + @defgroup tfsv_comp --- rectangular full packed (RFP) --- + @defgroup tftri tftri: triangular inverse, RFP + + @defgroup tbsv_comp --- banded --- + @defgroup tbcon tbcon: condition number estimate + @defgroup tbtrs tbtrs: triangular solve + @defgroup latbs latbs: triangular solve with scaling + @defgroup tbrfs tbrfs: triangular iterative refinement + @} + + @defgroup solve_aux_grp Auxiliary routines + @{ + @defgroup lacn2 lacn2: 1-norm estimate, e.g., || A^{-1} ||_1 in gecon + @defgroup lacon lacon: 1-norm estimate, e.g., || A^{-1} ||_1 in gecon, old + @defgroup la_lin_berr la_lin_berr: backward error + @} + @} + + @defgroup gels_top Least squares + @{ + @defgroup gels_driver_grp Standard least squares, min || Ax - b ||_2 + @{ + @defgroup gels gels: least squares using QR/LQ + @defgroup gelst gelst: least squares using QR/LQ with T matrix + @defgroup gelss gelss: least squares using SVD, QR iteration + @defgroup gelsd gelsd: least squares using SVD, divide and conquer + @defgroup gelsy gelsy: least squares using complete orthogonal factor + @defgroup getsls getsls: least squares using tall-skinny QR/LQ + @} + + @defgroup ggls_driver_grp Constrained least squares + @{ + @defgroup gglse gglse: equality-constrained least squares + @defgroup ggglm ggglm: Gauss-Markov linear model + @} + + @defgroup gels_aux_grp Auxiliary routines + @{ + @defgroup laic1 laic1: condition estimate, step in gelsy + @defgroup lals0 lals0: back multiplying factors, step in gelsd + @defgroup lalsa lalsa: SVD of coefficient matrix, step in gelsd + @defgroup lalsd lalsd: uses SVD for least squares, step in gelsd + @} + @} + + @defgroup unitary_top Orthogonal/unitary factors (QR, CS, etc.) + @{ + @defgroup geqr_comp_grp QR + @{ + @defgroup geqr_comp1 --- flexible --- + @defgroup geqr geqr: QR factor, flexible + @defgroup gemqr gemqr: multiply by Q from geqr + + @defgroup geqr_comp2 --- classic --- + @defgroup geqrf geqrf: QR factor + @defgroup geqr2 geqr2: QR factor, level 2 + @defgroup ungqr {un,or}gqr: generate explicit Q from geqrf + @defgroup ung2r {un,or}g2r: generate explicit Q from geqrf, level 2 + @defgroup unmqr {un,or}mqr: multiply by Q from geqrf + @defgroup unm2r {un,or}m2r: multiply by Q from geqrf, level 2 + + @defgroup geqr_comp3 --- with T --- + @defgroup geqrt geqrt: QR factor, with T + @defgroup geqrt2 geqrt2: QR factor, with T, level 2 + @defgroup geqrt3 geqrt3: QR factor, with T, recursive panel + @defgroup gemqrt gemqrt: multiply by Q from geqrt + + @defgroup geqr_comp4 --- positive --- + @defgroup geqrfp geqrfp: QR factor, diag( R ) ≥ 0 + @defgroup geqr2p geqr2p: QR factor, diag( R ) ≥ 0, level 2 + @} + + @defgroup geqpf_comp_grp QR with pivoting + @{ + @defgroup geqp3 geqp3: QR factor with pivoting, level 3 + @defgroup laqp2 laqp2: step of geqp3 + @defgroup laqps laqps: step of geqp3 + @} + + @defgroup getsqr_comp_grp QR, tall-skinny + @{ + @defgroup latsqr latsqr: tall-skinny QR factor + @defgroup ungtsqr {un,or}gtsqr: generate Q from latsqr + @defgroup ungtsqr_row {un,or}gtsqr_row: generate Q from latsqr + @defgroup larfb_gett larfb_gett: step in ungtsqr_row + @defgroup lamtsqr lamtsqr: multiply by Q from latsqr + @defgroup getsqrhrt getsqrhrt: tall-skinny QR factor, with Householder reconstruction + @defgroup unhr_col {un,or}hr_col: Householder reconstruction + @defgroup launhr_col_getrfnp la{un,or}hr_col_getrfnp: LU factor without pivoting + @defgroup launhr_col_getrfnp2 la{un,or}hr_col_getrfnp2: LU factor without pivoting, level 2 + @} + + @defgroup tpqr_comp_grp QR, triangular-pentagonal + @{ + @defgroup tpqrt tpqrt: QR factor + @defgroup tpqrt2 tpqrt2: QR factor, level 2 + @defgroup tpmqrt tpmqrt: applies Q + @defgroup tprfb tprfb: applies Q (like larfb) + @} + + @defgroup ggqr_comp_grp Generalized QR + @{ + @defgroup ggqrf ggqrf: Generalized QR factor + @} + + @defgroup gelq_comp_grp LQ + @{ + @defgroup gelq_comp1 --- flexible --- + @defgroup gelq gelq: LQ factor, flexible + @defgroup gemlq gemlq: multiply by Q from gelq + + @defgroup gelq_comp2 --- classic --- + @defgroup gelqf gelqf: LQ factor + @defgroup gelq2 gelq2: LQ factor, level 2 + @defgroup unglq {un,or}glq: generate explicit Q from gelqf + @defgroup ungl2 {un,or}gl2: generate explicit Q, level 2, step in unglq + @defgroup unmlq {un,or}mlq: multiply by Q from gelqf + @defgroup unml2 {un,or}ml2: multiply by Q, level 2, step in unmlq + + @defgroup gelq_comp3 --- with T --- + @defgroup gelqt gelqt: LQ factor, with T + @defgroup gelqt3 gelqt3: LQ factor, with T, recursive + @defgroup gemlqt gemlqt: multiply by Q from gelqt + @} + + @defgroup geswlq_comp_grp LQ, short-wide + @{ + @defgroup laswlq laswlq: short-wide LQ factor + @defgroup lamswlq lamswlq: multiply by Q from laswlq + @} + + @defgroup tplq_comp_grp LQ, triangular-pentagonal + @{ + @defgroup tplqt tplqt: QR factor + @defgroup tplqt2 tplqt2: QR factor, level 2 + @defgroup tpmlqt tpmlqt: applies Q + @} + + @defgroup geql_comp_grp QL + @{ + @defgroup geqlf geqlf: QL factor + @defgroup geql2 geql2: QL factor, level 2 + @defgroup ungql {un,or}gql: generate explicit Q from geqlf + @defgroup unmql {un,or}mql: multiply by Q from geqlf + @defgroup ung2l {un,or}g2l: step in ungql + @defgroup unm2l {un,or}m2l: step in unmql + @} + + @defgroup gerq_comp_grp RQ + @{ + @defgroup gerqf gerqf: RQ factor + @defgroup gerq2 gerq2: RQ factor, level 2 + @defgroup ungrq {un,or}grq: generate explicit Q from gerqf + @defgroup unmrq {un,or}mrq: multiply by Q from gerqf + @defgroup unmr2 {un,or}mr2: step in unmrq + @defgroup ungr2 {un,or}gr2: step in ungrq + @} + + @defgroup ggrq_comp_grp Generalized RQ + @{ + @defgroup ggrqf ggrqf: Generalized RQ factor + @} + + @defgroup gerz_comp_grp RZ + @{ + @defgroup tzrzf tzrzf: RZ factor + @defgroup latrz latrz: RZ factor step + @defgroup unmrz {un,or}mrz: multiply by Z from tzrzf + @defgroup unmr3 {un,or}mr3: step in unmrz + @defgroup larz larz: apply reflector + @defgroup larzb larzb: apply block reflector + @defgroup larzt larzt: generate T matrix + @} + + @defgroup gecs_comp_grp Cosine-Sine (CS) decomposition + @{ + @defgroup bbcsd bbcsd: ?? + @defgroup uncsd {un,or}csd: ?? + @defgroup uncsd2by1 {un,or}csd2by1: ?? + @defgroup unbdb {un,or}bdb: bidiagonalize partitioned unitary matrix, step in uncsd + @defgroup unbdb1 {un,or}bdb1: step in uncsd2by1 + @defgroup unbdb2 {un,or}bdb2: step in uncsd2by1 + @defgroup unbdb3 {un,or}bdb3: step in uncsd2by1 + @defgroup unbdb4 {un,or}bdb4: step in uncsd2by1 + @defgroup unbdb5 {un,or}bdb5: step in uncsd2by1 + @defgroup unbdb6 {un,or}bdb6: step in uncsd2by1 + + @defgroup lapmr lapmr: permute rows + @defgroup lapmt lapmt: permute cols + @} + + @defgroup reflector_aux_grp Householder reflectors + @{ + @defgroup larf larf: apply Householder reflector + @defgroup larfx larfx: apply Householder reflector, unrolled + @defgroup larfy larfy: apply Householder reflector symmetrically (2-sided) + @defgroup larfb larfb: apply block Householder reflector + @defgroup larfg larfg: generate Householder reflector + @defgroup larfgp larfgp: generate Householder reflector, beta ≥ 0 + @defgroup larft larft: generate T matrix + @} + + @defgroup rot_aux_grp Givens/Jacobi plane rotations + @{ + @defgroup lartg lartg: generate plane rotation, more accurate than BLAS rot + @defgroup lartgp lartgp: generate plane rotation, more accurate than BLAS rot + @defgroup lasr lasr: apply series of plane rotations + @defgroup largv largv: generate vector of plane rotations + @defgroup lartv lartv: apply vector of plane rotations to vectors + @defgroup lar2v lar2v: apply vector of plane rotations to 2x2 matrices + @defgroup lacrt lacrt: apply plane rotation (unused?) + @} + @} + + @defgroup geev_top Non-symmetric eigenvalues + @{ + @defgroup geev_driver_grp Standard eig driver, AV = VΛ + @{ + @defgroup geev geev: eig + @defgroup geevx geevx: eig, expert + + @defgroup gees gees: Schur form + @defgroup geesx geesx: Schur form, expert + @} + + @defgroup ggev_driver_grp Generalized eig driver + @{ + @defgroup ggev3 ggev3: eig + @defgroup ggev ggev: eig, unblocked + @defgroup ggevx ggevx: eig, expert + + @defgroup gges3 gges3: Schur form + @defgroup gges gges: Schur form, unblocked + @defgroup ggesx ggesx: Schur form, expert + @} + + @defgroup gedmd DMD driver, Dynamic Mode Decomposition + + @defgroup geev_comp_grp Eig computational routines + @{ + @defgroup gebal gebal: balance matrix + @defgroup gehrd gehrd: reduction to Hessenberg + @defgroup gehd2 gehd2: reduction to Hessenberg, level 2 + @defgroup lahr2 lahr2: step in gehrd + @defgroup unghr {un,or}ghr: generate Q from gehrd + @defgroup unmhr {un,or}mhr: multiply by Q from gehrd + @defgroup gebak gebak: back-transform eigvec + @defgroup hseqr hseqr: Hessenberg eig, QR iteration + @defgroup hsein hsein: Hessenberg inverse iteration for eigvec + @defgroup trevc trevc: eigenvectors of triangular Schur form, old + @defgroup trevc3 trevc3: eigenvectors of triangular Schur form, blocked + @defgroup laln2 laln2: 1x1 or 2x2 solve, step in trevc + + @defgroup trsyl trsyl: Sylvester equation + @defgroup trsyl3 trsyl3: Sylvester equation, level 3 + @defgroup lasy2 lasy2: Sylvester equation + + @defgroup trsna trsna: eig condition numbers + @defgroup laqtr laqtr: quasi-triangular solve + + @defgroup trexc trexc: reorder Schur form + @defgroup trsen trsen: reorder Schur form + @defgroup laexc laexc: reorder Schur form + + @defgroup lanv2 lanv2: 2x2 Schur factor + + @defgroup laqr_group --- hseqr auxiliary --- + @defgroup laein laein: eigvec by Hessenberg inverse iteration + @defgroup lahqr lahqr: eig of Hessenberg, step in hseqr + @defgroup laqr0 laqr0: eig of Hessenberg, step in hseqr + @defgroup laqr1 laqr1: step in hseqr + @defgroup laqr2 laqr2: step in hseqr + @defgroup laqr3 laqr3: step in hseqr + @defgroup laqr4 laqr4: eig of Hessenberg, step in hseqr + @defgroup laqr5 laqr5: step in hseqr + + @defgroup iparmq iparmq: set parameters for hseqr + + @defgroup laqz_group --- ggev3, gges3 auxiliary --- + @defgroup laqz0 laqz0: step in ggev3, gges3 + @defgroup laqz1 laqz1: step in ggev3, gges3 + @defgroup laqz2 laqz2: step in ggev3, gges3 + @defgroup laqz3 laqz3: step in ggev3, gges3 + @defgroup laqz4 laqz4: step in ggev3, gges3 + @} + + @defgroup ggev_comp_grp Generalized eig computational routines + @{ + @defgroup ggbal ggbal: balance matrix + @defgroup gghrd gghrd: reduction to Hessenberg + @defgroup gghd3 gghd3: reduction to Hessenberg, level 3 + @defgroup hgeqz hgeqz: generalized Hessenberg eig + @defgroup ggbak ggbak: back-transform eigvec + @defgroup tgsen tgsen: reorder generalized Schur form + @defgroup tgsna tgsna: reciprocal cond est + @defgroup tgsyl tgsyl: Sylvester equation + @defgroup tgsy2 tgsy2: Sylvester equation panel (?) + @defgroup unm22 {un,or}m22: multiply by banded Q, step in gghd3 + @defgroup lagv2 lagv2: 2x2 generalized Schur factor + @defgroup tgevc tgevc: eigvec of pair of matrices + @defgroup tgexc tgexc: reorder generalized Schur form + @defgroup tgex2 tgex2: reorder generalized Schur form + @} + @} + + @defgroup heev_top Hermitian/symmetric eigenvalues + @{ + @defgroup heev_driver_grp Standard eig driver, AV = VΛ + @{ + @defgroup heev_driver --- full --- + @defgroup heev {he,sy}ev: eig, QR iteration + @defgroup heevd {he,sy}evd: eig, divide and conquer + @defgroup heevr {he,sy}evr: eig, MRRR + @defgroup heevx {he,sy}evx: eig, bisection + + @defgroup heev_driver2 --- full, 2-stage --- + @defgroup heev_2stage {he,sy}ev_2stage: eig, QR iteration + @defgroup heevd_2stage {he,sy}evd_2stage: eig, divide and conquer + @defgroup heevr_2stage {he,sy}evr_2stage: eig, MRRR + @defgroup heevx_2stage {he,sy}evx_2stage: eig, bisection + + @defgroup hpev_driver --- packed --- + @defgroup hpev {hp,sp}ev: eig, QR iteration + @defgroup hpevd {hp,sp}evd: eig, divide and conquer + @defgroup hpevx {hp,sp}evx: eig, bisection + + @defgroup hbev_driver --- banded --- + @defgroup hbev {hb,sb}ev: eig, QR iteration + @defgroup hbevd {hb,sb}evd: eig, divide and conquer + @defgroup hbevx {hb,sb}evx: eig, bisection + + @defgroup hbev_driver2 --- banded, 2nd-stage --- + @defgroup hbev_2stage {hb,sb}ev_2stage: eig, QR iteration + @defgroup hbevd_2stage {hb,sb}evd_2stage: eig, divide and conquer + @defgroup hbevx_2stage {hb,sb}evx_2stage: eig, bisection + + @defgroup stev_driver --- tridiagonal --- + @defgroup stev stev: eig, QR iteration + @defgroup stevd stevd: eig, divide and conquer + @defgroup stevr stevr: eig, MRRR + @defgroup stevx stevx: eig, bisection + @defgroup pteqr pteqr: eig, positive definite tridiagonal + + @defgroup stebz stebz: eig, Kahan + @defgroup sterf sterf: eig, QR iteration + @defgroup stedc stedc: eig, divide and conquer + @defgroup stegr stegr: eig, bisection, see stemr + @defgroup stein stein: eig, inverse iteration + @defgroup stemr stemr: eig, relatively robust representation (RRR) + @defgroup steqr steqr: eig, QR iteration + @} + + @defgroup hegv_driver_grp Generalized eig driver, AV = BVΛ, etc. + @{ + @defgroup hegv_driver --- full --- + @defgroup hegv {he,sy}gv: eig, QR iteration + @defgroup hegv_2stage {he,sy}gv_2stage: eig, QR iteration, 2-stage + @defgroup hegvd {he,sy}gvd: eig, divide and conquer + @defgroup hegvx {he,sy}gvx: eig, bisection + + @defgroup hpgv_driver --- packed --- + @defgroup hpgv {hp,sp}gv: eig, QR iteration + @defgroup hpgvd {hp,sp}gvd: eig, divide and conquer + @defgroup hpgvx {hp,sp}gvx: eig, bisection + + @defgroup hbgv_driver --- banded --- + @defgroup hbgv {hb,sb}gv: eig, QR iteration + @defgroup hbgvd {hb,sb}gvd: eig, divide and conquer + @defgroup hbgvx {hb,sb}gvx: eig, bisection + @} + + @defgroup heev_comp_grp Eig computational routines + @{ + @defgroup heev_comp --- full --- + @defgroup disna disna: eig condition numbers + @defgroup hetrd {he,sy}trd: reduction to tridiagonal + @defgroup hetd2 {he,sy}td2: reduction to tridiagonal, level 2 + @defgroup latrd latrd: step in hetrd + @defgroup ungtr {un,or}gtr: generate Q from hetrd + @defgroup unmtr {un,or}mtr: multiply by Q from hetrd + + @defgroup hetrd_2stage {he,sy}trd_2stage: reduction to tridiagonal, 2-stage + @defgroup hetrd_he2hb {he,sy}trd_he2hb: full to band (1st stage) + @defgroup hetrd_hb2st {he,sy}trd_hb2st: band to tridiagonal (2nd stage) + @defgroup hb2st_kernels {hb,sb}2st_kernels: band to tridiagonal (2nd stage) + + @defgroup lae2 lae2: 2x2 eig, step in steqr, stemr + @defgroup laesy laesy: 2x2 eig + @defgroup laev2 laev2: 2x2 eig + @defgroup lagtf lagtf: LU factor of (T - λI) + @defgroup lagts lagts: LU solve of (T - λI) x = y + + @defgroup hpev_comp --- packed --- + @defgroup hptrd {hp,sp}trd: reduction to tridiagonal + @defgroup upgtr {up,op}gtr: generate Q from hetrd + @defgroup upmtr {up,op}mtr: multiply by Q from hptrd + + @defgroup hbev_comp --- banded --- + @defgroup hbtrd {hb,sb}trd: reduction to tridiagonal + @} + + @defgroup hegv_comp_grp Generalized eig computational routines + @{ + @defgroup hegst {he,sy}gst: reduction to standard form + @defgroup hegs2 {he,sy}gs2: reduction to standard form, level 2 + @defgroup hpgst {hp,sp}gst: reduction to standard form, packed + @defgroup hbgst {hb,sb}gst: reduction to standard form, banded + @defgroup pbstf pbstf: split Cholesky factor, use with hbgst + @defgroup lag2 lag2: 2x2 eig + @} + + @defgroup stev_comp_grp tridiag bisection routines + @{ + @defgroup laebz laebz: counts eigvals <= value + @defgroup laneg laneg: Sturm count + @} + + @defgroup laed_comp_grp tridiag divide and conquer (D&C) routines + @{ + @defgroup laed0 laed0: D&C step: top level solver + @defgroup laed1 laed1: D&C step: merge subproblems + @defgroup laed2 laed2: D&C step: deflation + @defgroup laed3 laed3: D&C step: secular equation + @defgroup laed4 laed4: D&C step: secular equation nonlinear solver + @defgroup laed5 laed5: D&C step: secular equation, 2x2 + @defgroup laed6 laed6: D&C step: secular equation Newton step + @defgroup lamrg lamrg: permutation to merge 2 sorted lists + + @defgroup laed_comp2 --- eig value only or update Q --- + @defgroup laed7 laed7: D&C step: merge subproblems + @defgroup laed8 laed8: D&C step: deflation + @defgroup laed9 laed9: D&C step: secular equation + @defgroup laeda laeda: D&C step: z vector + @} + + @defgroup larr_comp_grp tridiag RRR routines + @{ + @defgroup larra larra: step in stemr + @defgroup larrb larrb: step in stemr + @defgroup larrc larrc: step in stemr + @defgroup larrd larrd: step in stemr, tridiag eig + @defgroup larre larre: step in stemr + @defgroup larrf larrf: step in stemr, find relative robust representation (RRR) + @defgroup larrj larrj: step in stemr, refine eigval estimates + @defgroup larrk larrk: step in stemr, compute one eigval + @defgroup larrr larrr: step in stemr, test to do expensive tridiag eig algorithm + @defgroup larrv larrv: eig tridiagonal, step in stemr & stegr + @defgroup lar1v lar1v: step in larrv, hence stemr & stegr + @} + @} + + @defgroup svd_top Singular Value Decomposition (SVD) + @{ + @defgroup svd_driver_grp Standard SVD driver, A = UΣV^H + @{ + @defgroup gesvd_driver --- full --- + @defgroup gesvd gesvd: SVD, QR iteration + @defgroup gesvdq gesvdq: SVD, QR with pivoting + @defgroup gesdd gesdd: SVD, divide and conquer + @defgroup gesvdx gesvdx: SVD, bisection + @defgroup gejsv gejsv: SVD, Jacobi, high-level + @defgroup gesvj gesvj: SVD, Jacobi, low-level + + @defgroup bdsvd_driver --- bidiagonal --- + @defgroup bdsqr bdsqr: bidiagonal SVD, QR iteration (dqds) + @defgroup bdsdc bdsdc: bidiagonal SVD, divide and conquer + @defgroup bdsvdx bdsvdx: bidiagonal SVD, bisection + @} + + @defgroup ggsvd_driver_grp Generalized SVD driver + @{ + @defgroup ggsvd3 ggsvd3: SVD, QR iteration + @} + + @defgroup gesvd_comp_grp SVD computational routines + @{ + @defgroup gebrd gebrd: reduction to bidiagonal + @defgroup gebd2 gebd2: reduction to bidiagonal, level 2 + @defgroup labrd labrd: step in gebrd + @defgroup gbbrd gbbrd: band to bidiagonal + @defgroup ungbr {un,or}gbr: generate Q, P from gebrd + @defgroup unmbr {un,or}mbr: multiply by Q, P from gebrd + + @defgroup gesvd_aux --- auxiliary routines --- + @defgroup gsvj0 gsvj0: step in gesvj + @defgroup gsvj1 gsvj1: step in gesvj + @defgroup las2 las2: 2x2 triangular SVD + @defgroup lasv2 lasv2: 2x2 triangular SVD + @defgroup lartgs lartgs: generate plane rotation for bidiag SVD + @} + + @defgroup ggsvd_comp_grp Generalized SVD computational routines + @{ + @defgroup ggsvp3 ggsvp3: step in ggsvd + @defgroup tgsja tgsja: generalized SVD of trapezoidal matrices, step in ggsvd3 + @defgroup lags2 lags2: 2x2 orthogonal factor, step in tgsja + @defgroup lapll lapll: linear dependence of 2 vectors + @} + + @defgroup lasq_comp_grp bidiag QR iteration routines + @{ + @defgroup lasq1 lasq1: dqds step + @defgroup lasq2 lasq2: dqds step + @defgroup lasq3 lasq3: dqds step + @defgroup lasq4 lasq4: dqds step + @defgroup lasq5 lasq5: dqds step + @defgroup lasq6 lasq6: dqds step + @} + + @defgroup lasd_comp_grp bidiag D&C routines + @{ + @defgroup lasd0 lasd0: D&C step: top level solver + @defgroup lasdt lasdt: D&C step: tree + @defgroup lasd1 lasd1: D&C step: merge subproblems + @defgroup lasd2 lasd2: D&C step: deflation + @defgroup lasd3 lasd3: D&C step: secular equation + @defgroup lasd4 lasd4: D&C step: secular equation nonlinear solver + @defgroup lasd5 lasd5: D&C step: secular equation, 2x2 + @defgroup lasdq lasdq: D&C step: leaf using bdsqr + + @defgroup lasd_comp2 --- singular values only or factored form --- + @defgroup lasda lasda: D&C step: top level solver + @defgroup lasd6 lasd6: D&C step: merge subproblems + @defgroup lasd7 lasd7: D&C step: deflation + @defgroup lasd8 lasd8: D&C step: secular equation + @} + @} + + @defgroup blas_like_top BLAS-like + @{ + @defgroup set_grp Initialize, copy, convert + @{ + @defgroup laset laset: set matrix + @defgroup larnv larnv: random vector + @defgroup laruv laruv: random uniform vector + + @defgroup lacpy lacpy: copy matrix + + @defgroup lacp2 lacp2: general matrix, convert real to complex + @defgroup _lag2_ _lag2_: general matrix, convert double <=> single + @defgroup _lat2_ _lat2_: triangular matrix, convert double <=> single + + @defgroup tfttp tfttp: triangular matrix, RFP (tf) to packed (tp) + @defgroup tfttr tfttr: triangular matrix, RFP (tf) to full (tr) + @defgroup tpttf tpttf: triangular matrix, packed (tp) to RFP (tf) + @defgroup tpttr tpttr: triangular matrix, packed (tp) to full (tr) + @defgroup trttf trttf: triangular matrix, full (tr) to RFP (tf) + @defgroup trttp trttp: triangular matrix, full (tr) to packed (tp) + @} + + @defgroup norm_grp Matrix norm + @{ + @defgroup lange lange: general matrix + @defgroup langb langb: general matrix, banded + @defgroup langt langt: general matrix, tridiagonal + + @defgroup lanhs lanhs: Hessenberg + + @defgroup lanhe lan{he,sy}: Hermitian/symmetric matrix + @defgroup lanhf lan{hf,sf}: Hermitian/symmetric matrix, RFP + @defgroup lanhp lan{hp,sp}: Hermitian/symmetric matrix, packed + @defgroup lanhb lan{hb,sb}: Hermitian/symmetric matrix, banded + @defgroup lanht lan{ht,st}: Hermitian/symmetric matrix, tridiagonal + + @defgroup lantr lantr: triangular matrix + @defgroup lantp lantp: triangular matrix, packed + @defgroup lantb lantb: triangular matrix, banded + @} + + @defgroup blas0_like_grp Scalar operations + @{ + @defgroup isnan isnan: test for NaN + @defgroup laisnan laisnan: test for NaN, unoptimized + @defgroup ladiv ladiv: complex divide + @defgroup lapy2 lapy2: robust sqrt( x^2 + y^2 ) + @defgroup lapy3 lapy3: robust sqrt( x^2 + y^2 + z^2 ) + @defgroup larmm larmm: scale factor to avoid overflow, step in latrs + @} + + @defgroup blas1_like_grp Level 1 BLAS-like vector ops + @{ + @defgroup lacgv lacgv: conjugate vector + @defgroup lasrt lasrt: sort vector + @defgroup lassq lassq: sum-of-squares, avoiding over/underflow + @defgroup rscl rscl: scale vector by reciprocal + @} + + @defgroup blas2_like_grp Level 2 BLAS-like matrix-vector ops + @{ + @defgroup ilalc ilalc: find non-zero col + @defgroup ilalr ilalr: find non-zero row + @defgroup lascl lascl: scale matrix + @defgroup la_geamv la_geamv: matrix-vector multiply |A| * |x|, general + @defgroup la_gbamv la_gbamv: matrix-vector multiply |A| * |x|, general banded + @defgroup la_heamv la_heamv: matrix-vector multiply |A| * |x|, Hermitian/symmetric + @defgroup lascl2 lascl2: diagonal scale matrix, A = D A + @defgroup larscl2 larscl2: reciprocal diagonal scale matrix, A = D^{-1} A + @defgroup la_wwaddw la_wwaddw: add to double-double or single-single vector + @} + + @defgroup blas3_like_grp Level 3 BLAS-like matrix-matrix ops + @{ + @defgroup lagtm lagtm: tridiagonal matrix-matrix multiply + @defgroup lacrm lacrm: complex * real matrix-matrix multiply + @defgroup larcm larcm: real * complex matrix-matrix multiply + @defgroup hfrk hfrk: Hermitian rank-k update, RFP format + @defgroup tfsm tfsm: triangular-matrix solve, RFP format + @} + @} + + @defgroup aux_top Auxiliary routines + @{ + @defgroup aux_grp Other auxiliary routines + @{ + @defgroup lsame lsame: string comparison + @defgroup lsamen lsamen: string comparison + @defgroup roundup_lwork roundup_lwork: fix rounding integer to float + @defgroup second second: wall clock timer + @} + + @defgroup params_grp Parameters + @{ + @defgroup lamch lamch: machine parameters + @defgroup lamc1 lamc1: ?? + @defgroup lamc2 lamc2: ?? + @defgroup lamc3 lamc3: ?? + @defgroup lamc4 lamc4: ?? + @defgroup lamc5 lamc5: ?? + @defgroup labad labad: over/underflow on obsolete pre-IEEE machines + @defgroup ilaver ilaver: LAPACK version + @defgroup ilaenv ilaenv: tuning parameters + @defgroup ilaenv2stage ilaenv2stage: tuning parameters for 2-stage eig + @defgroup iparam2stage iparam2stage: sets parameters for 2-stage eig + @defgroup ieeeck ieeeck: verify inf and NaN are safe + @defgroup la_constants la_constants: Fortran 95 module of constants + + @defgroup blast_aux --- BLAST constants --- + @defgroup iladiag iladiag: diag string to BLAST const + @defgroup ilaprec ilaprec: precision string to BLAST const + @defgroup ilatrans ilatrans: trans string to BLAST const + @defgroup ilauplo ilauplo: uplo string to BLAST const + @defgroup la_transtype la_transtype: BLAST const to string + @} + + @defgroup xerbla_grp Error reporting + @{ + @defgroup xerbla xerbla: error reporting + @defgroup xerbla_array xerbla_array: error reporting, callable from C + @} + @} +@} + +@defgroup blas_top BLAS +BLAS are defined by three papers: +Basic linear algebra subprograms for {FORTRAN} usage, Lawson et al, 1979. +An extended set of {FORTRAN} basic linear algebra subprograms, Dongarra et al, 1988. +A set of level 3 basic linear algebra subprograms, Dongarra et al, 1990. +Some BLAS-like routines (e.g., csymv, crot, csum1, icmax1) exist in +LAPACK rather than the classic BLAS. +These were extended by the Extra Precision BLAS (XBLAS, not documented here) +https://www.netlib.org/xblas/ + +@{ + @defgroup scalar_grp Scalar operations + @{ + @defgroup abs1 abs1: | real( x ) | + | imag( x ) | + @} + + @defgroup blas1_grp Level 1 BLAS: vector ops + @{ + @defgroup asum asum: sum | real( x_i ) | + | imag( x_i ) | + @defgroup sum1 sum1: sum | x_i | (in LAPACK) + @defgroup axpy axpy: y = ax + y + @defgroup copy copy: y = x + @defgroup dot dot: x^H x and x^T x + @defgroup iamax iamax: argmax_i | real( x_i ) | + | imag( x_i ) | + @defgroup imax1 imax1: argmax_i | x_i | (in LAPACK) + @defgroup nrm2 nrm2: || x ||_2 + @defgroup scal scal: x = alpha x + @defgroup swap swap: x <=> y + + @defgroup rot_comp --- Givens/Jacobi plane rotations --- + @defgroup rot rot: apply plane rotation ([cz]rot in LAPACK) + @defgroup rotg rotg: generate plane rotation (cf. lartg) + @defgroup rotm rotm: apply modified (fast) plane rotation + @defgroup rotmg rotmg: generate modified (fast) plane rotation + @} + + @defgroup blas2_grp Level 2 BLAS: matrix-vector ops + @{ + @defgroup blas2_full --- full --- + @defgroup gemv gemv: general matrix-vector multiply + @defgroup ger ger: general matrix rank-1 update + + @defgroup hemv {he,sy}mv: Hermitian/symmetric matrix-vector multiply ([cz]symv in LAPACK) + @defgroup her {he,sy}r: Hermitian/symmetric rank-1 update + @defgroup her2 {he,sy}r2: Hermitian/symmetric rank-2 update + + @defgroup trmv trmv: triangular matrix-vector multiply + @defgroup trsv trsv: triangular matrix-vector solve + + @defgroup blas2_packed --- packed --- + @defgroup hpmv {hp,sp}mv: Hermitian/symmetric matrix-vector multiply + @defgroup hpr {hp,sp}r: Hermitian/symmetric rank-1 update + @defgroup hpr2 {hp,sp}r2: Hermitian/symmetric rank-2 update + + @defgroup tpmv tpmv: triangular matrix-vector multiply + @defgroup tpsv tpsv: triangular matrix-vector solve + + @defgroup blas2_banded --- banded --- + @defgroup gbmv gbmv: general matrix-vector multiply + + @defgroup hbmv {hb,sb}mv: Hermitian/symmetric matrix-vector multiply + + @defgroup tbmv tbmv: triangular matrix-vector multiply + @defgroup tbsv tbsv: triangular matrix-vector solve + @} + + @defgroup blas3_grp Level 3 BLAS: matrix-matrix ops + @{ + @defgroup gemm gemm: general matrix-matrix multiply + + @defgroup hemm {he,sy}mm: Hermitian/symmetric matrix-matrix multiply + @defgroup herk {he,sy}rk: Hermitian/symmetric rank-k update + @defgroup her2k {he,sy}r2k: Hermitian/symmetric rank-2k update + + @defgroup trmm trmm: triangular matrix-matrix multiply + @defgroup trsm trsm: triangular matrix-matrix solve + @} +@} + **/ From 3d9e20f61455ca6893744c2f9a0e19d89d9c5998 Mon Sep 17 00:00:00 2001 From: Martin Kroeker Date: Sat, 25 Nov 2023 18:51:54 +0100 Subject: [PATCH 24/60] Update version to 3.12.0 --- lapack-netlib/INSTALL/ilaver.f | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/lapack-netlib/INSTALL/ilaver.f b/lapack-netlib/INSTALL/ilaver.f index a246c37cb..1827d5cd2 100644 --- a/lapack-netlib/INSTALL/ilaver.f +++ b/lapack-netlib/INSTALL/ilaver.f @@ -44,7 +44,6 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date November 2019 * *> \ingroup auxOTHERauxiliary * @@ -60,7 +59,7 @@ INTEGER VERS_MAJOR, VERS_MINOR, VERS_PATCH * ===================================================================== VERS_MAJOR = 3 - VERS_MINOR = 11 + VERS_MINOR = 12 VERS_PATCH = 0 * ===================================================================== * From 578f0f95901617941c7de5ddc62fa97f12f9c0a0 Mon Sep 17 00:00:00 2001 From: Martin Kroeker Date: Sat, 25 Nov 2023 18:53:16 +0100 Subject: [PATCH 25/60] Update version number to 3.12.0 --- lapack-netlib/INSTALL/ilaver.c | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/lapack-netlib/INSTALL/ilaver.c b/lapack-netlib/INSTALL/ilaver.c index 184e9b78d..d64c841a2 100644 --- a/lapack-netlib/INSTALL/ilaver.c +++ b/lapack-netlib/INSTALL/ilaver.c @@ -315,7 +315,6 @@ typedef struct Namelist Namelist; /* > \author Univ. of Colorado Denver */ /* > \author NAG Ltd. */ -/* > \date November 2019 */ /* > \ingroup auxOTHERauxiliary */ @@ -332,7 +331,7 @@ typedef struct Namelist Namelist; /* ===================================================================== */ *vers_major__ = 3; - *vers_minor__ = 11; + *vers_minor__ = 12; *vers_patch__ = 0; /* ===================================================================== */ From 08be9004f89e41607e4c19de1e3d1018ee536728 Mon Sep 17 00:00:00 2001 From: Martin Kroeker Date: Sat, 25 Nov 2023 18:57:17 +0100 Subject: [PATCH 26/60] Update version number and copyright date to Reference-LAPACK 3.12.0 --- lapack-netlib/CMakeLists.txt | 240 ++++++++++++++++------------------- lapack-netlib/LICENSE | 6 +- lapack-netlib/README.md | 3 +- 3 files changed, 111 insertions(+), 138 deletions(-) diff --git a/lapack-netlib/CMakeLists.txt b/lapack-netlib/CMakeLists.txt index fefaa8b89..f1f47ae24 100644 --- a/lapack-netlib/CMakeLists.txt +++ b/lapack-netlib/CMakeLists.txt @@ -1,9 +1,9 @@ -cmake_minimum_required(VERSION 3.2) +cmake_minimum_required(VERSION 3.6) -project(LAPACK Fortran C) +project(LAPACK) set(LAPACK_MAJOR_VERSION 3) -set(LAPACK_MINOR_VERSION 11) +set(LAPACK_MINOR_VERSION 12) set(LAPACK_PATCH_VERSION 0) set( LAPACK_VERSION @@ -45,6 +45,14 @@ if(_is_coverage_build) find_package(codecov) endif() +# Use valgrind if it is found +option( LAPACK_TESTING_USE_PYTHON "Use Python for testing. Disable it on memory checks." ON ) +find_program( MEMORYCHECK_COMMAND valgrind ) +if( MEMORYCHECK_COMMAND ) + message( STATUS "Found valgrind: ${MEMORYCHECK_COMMAND}" ) + set( MEMORYCHECK_COMMAND_OPTIONS "--leak-check=full --show-leak-kinds=all --track-origins=yes" ) +endif() + # By default test Fortran compiler complex abs and complex division option(TEST_FORTRAN_COMPILER "Test Fortran compiler complex abs and complex division" OFF) if( TEST_FORTRAN_COMPILER ) @@ -76,7 +84,7 @@ if( TEST_FORTRAN_COMPILER ) WORKING_DIRECTORY ${LAPACK_BINARY_DIR}/INSTALL COMMENT "Running test_zminMax in ${LAPACK_BINARY_DIR}/INSTALL with stderr: test_zminMax.err" SOURCES ${LAPACK_SOURCE_DIR}/INSTALL/test_zminMax.f ) - + endif() # By default static library @@ -99,6 +107,8 @@ else() set(LAPACKELIB "lapacke") set(TMGLIB "tmglib") endif() +# By default build standard API and extended _64 API +option(BUILD_INDEX64_EXT_API "Build Index-64 API as extended API with _64 suffix" ON) include(GNUInstallDirs) @@ -127,90 +137,6 @@ configure_file( include(PreventInSourceBuilds) include(PreventInBuildInstalls) -# Check if recursive flag exists -include(CheckFortranCompilerFlag) -if(CMAKE_Fortran_COMPILER_ID STREQUAL Flang) - check_fortran_compiler_flag("-Mrecursive" _MrecursiveFlag) -elseif(CMAKE_Fortran_COMPILER_ID STREQUAL GNU) - check_fortran_compiler_flag("-frecursive" _frecursiveFlag) -elseif(CMAKE_Fortran_COMPILER_ID STREQUAL Intel) - check_fortran_compiler_flag("-recursive" _recursiveFlag) -elseif(CMAKE_Fortran_COMPILER_ID STREQUAL XL) - check_fortran_compiler_flag("-qrecur" _qrecurFlag) -elseif(CMAKE_Fortran_COMPILER_ID STREQUAL NAG) - check_fortran_compiler_flag("-recursive" _recursiveFlag) -else() - message(WARNING "Fortran local arrays should be allocated on the stack." - " Please use a compiler which guarantees that feature." - " See https://github.com/Reference-LAPACK/lapack/pull/188 and references therein.") -endif() - -# Add recursive flag -if(_MrecursiveFlag) - string(REGEX MATCH "-Mrecursive" output_test "${CMAKE_Fortran_FLAGS}") - if(NOT output_test) - set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -Mrecursive" - CACHE STRING "Recursive flag must be set" FORCE) - endif() -elseif(_frecursiveFlag) - string(REGEX MATCH "-frecursive" output_test "${CMAKE_Fortran_FLAGS}") - if(NOT output_test) - set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -frecursive" - CACHE STRING "Recursive flag must be set" FORCE) - endif() -elseif(_recursiveFlag) - string(REGEX MATCH "-recursive" output_test "${CMAKE_Fortran_FLAGS}") - if(NOT output_test) - set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -recursive" - CACHE STRING "Recursive flag must be set" FORCE) - endif() -elseif(_qrecurFlag) - string(REGEX MATCH "-qrecur" output_test "${CMAKE_Fortran_FLAGS}") - if(NOT output_test) - set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -qrecur" - CACHE STRING "Recursive flag must be set" FORCE) - endif() -endif() - -if(UNIX) - if(CMAKE_Fortran_COMPILER_ID STREQUAL Intel) - set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -fp-model strict") - endif() - if(CMAKE_Fortran_COMPILER_ID STREQUAL XL) - set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -qnosave -qstrict") - endif() -# Delete libmtsk in linking sequence for Sun/Oracle Fortran Compiler. -# This library is not present in the Sun package SolarisStudio12.3-linux-x86-bin - string(REPLACE \;mtsk\; \; CMAKE_Fortran_IMPLICIT_LINK_LIBRARIES "${CMAKE_Fortran_IMPLICIT_LINK_LIBRARIES}") -endif() - -if(CMAKE_Fortran_COMPILER_ID STREQUAL Compaq) - if(WIN32) - if(CMAKE_GENERATOR STREQUAL "NMake Makefiles") - get_filename_component(CMAKE_Fortran_COMPILER_CMDNAM ${CMAKE_Fortran_COMPILER} NAME_WE) - message(STATUS "Using Compaq Fortran compiler with command name ${CMAKE_Fortran_COMPILER_CMDNAM}") - set(cmd ${CMAKE_Fortran_COMPILER_CMDNAM}) - string(TOLOWER "${cmd}" cmdlc) - if(cmdlc STREQUAL "df") - message(STATUS "Assume the Compaq Visual Fortran Compiler is being used") - set(CMAKE_Fortran_USE_RESPONSE_FILE_FOR_OBJECTS 1) - set(CMAKE_Fortran_USE_RESPONSE_FILE_FOR_INCLUDES 1) - #This is a workaround that is needed to avoid forward-slashes in the - #filenames listed in response files from incorrectly being interpreted as - #introducing compiler command options - if(${BUILD_SHARED_LIBS}) - message(FATAL_ERROR "Making of shared libraries with CVF has not been tested.") - endif() - set(str "NMake version 9 or later should be used. NMake version 6.0 which is\n") - set(str "${str} included with the CVF distribution fails to build Lapack because\n") - set(str "${str} the number of source files exceeds the limit for NMake v6.0\n") - message(STATUS ${str}) - set(CMAKE_Fortran_LINK_EXECUTABLE "LINK /out: ") - endif() - endif() - endif() -endif() - # Add option to enable flat namespace for symbol resolution on macOS if(APPLE) option(USE_FLAT_NAMESPACE "Use flat namespaces for symbol resolution during build and runtime." OFF) @@ -268,26 +194,6 @@ set(CMAKE_RUNTIME_OUTPUT_DIRECTORY ${LAPACK_BINARY_DIR}/bin) set(CMAKE_ARCHIVE_OUTPUT_DIRECTORY ${LAPACK_BINARY_DIR}/lib) set(CMAKE_LIBRARY_OUTPUT_DIRECTORY ${LAPACK_BINARY_DIR}/lib) -# -------------------------------------------------- -# Check for any necessary platform specific compiler flags -include(CheckLAPACKCompilerFlags) -CheckLAPACKCompilerFlags() - -# -------------------------------------------------- -# Check second function - -include(CheckTimeFunction) -set(TIME_FUNC NONE) -CHECK_TIME_FUNCTION(NONE TIME_FUNC) -CHECK_TIME_FUNCTION(INT_CPU_TIME TIME_FUNC) -CHECK_TIME_FUNCTION(EXT_ETIME TIME_FUNC) -CHECK_TIME_FUNCTION(EXT_ETIME_ TIME_FUNC) -CHECK_TIME_FUNCTION(INT_ETIME TIME_FUNC) -message(STATUS "--> Will use second_${TIME_FUNC}.f and dsecnd_${TIME_FUNC}.f as timing function.") - -set(SECOND_SRC ${LAPACK_SOURCE_DIR}/INSTALL/second_${TIME_FUNC}.f) -set(DSECOND_SRC ${LAPACK_SOURCE_DIR}/INSTALL/dsecnd_${TIME_FUNC}.f) - # deprecated LAPACK and LAPACKE routines option(BUILD_DEPRECATED "Build deprecated routines" OFF) message(STATUS "Build deprecated routines: ${BUILD_DEPRECATED}") @@ -380,18 +286,27 @@ endif() # Check the usage of the user provided or automatically found LAPACK libraries if(LAPACK_LIBRARIES) - include(CheckFortranFunctionExists) - set(CMAKE_REQUIRED_LIBRARIES ${LAPACK_LIBRARIES}) - # Check if new routine of 3.4.0 is in LAPACK_LIBRARIES - CHECK_FORTRAN_FUNCTION_EXISTS("dgeqrt" LATESTLAPACK_FOUND) - unset(CMAKE_REQUIRED_LIBRARIES) - if(LATESTLAPACK_FOUND) - message(STATUS "--> LAPACK supplied by user is WORKING, will use ${LAPACK_LIBRARIES}.") + include(CheckLanguage) + check_language(Fortran) + if(CMAKE_Fortran_COMPILER) + enable_language(Fortran) + include(CheckFortranFunctionExists) + set(CMAKE_REQUIRED_LIBRARIES ${LAPACK_LIBRARIES}) + # Check if new routine of 3.4.0 is in LAPACK_LIBRARIES + CHECK_FORTRAN_FUNCTION_EXISTS("dgeqrt" LATESTLAPACK_FOUND) + unset(CMAKE_REQUIRED_LIBRARIES) + if(LATESTLAPACK_FOUND) + message(STATUS "--> LAPACK supplied by user is WORKING, will use ${LAPACK_LIBRARIES}.") + else() + message(ERROR "--> LAPACK supplied by user is not WORKING or is older than LAPACK 3.4.0, CANNOT USE ${LAPACK_LIBRARIES}.") + message(ERROR "--> Will use REFERENCE LAPACK (by default)") + message(ERROR "--> Or Correct your LAPACK_LIBRARIES entry ") + message(ERROR "--> Or Consider checking USE_OPTIMIZED_LAPACK") + endif() else() - message(ERROR "--> LAPACK supplied by user is not WORKING or is older than LAPACK 3.4.0, CANNOT USE ${LAPACK_LIBRARIES}.") - message(ERROR "--> Will use REFERENCE LAPACK (by default)") - message(ERROR "--> Or Correct your LAPACK_LIBRARIES entry ") - message(ERROR "--> Or Consider checking USE_OPTIMIZED_LAPACK") + message(STATUS "--> LAPACK supplied by user is ${LAPACK_LIBRARIES}.") + message(STATUS "--> CMake couldn't find a Fortran compiler, so it cannot check if the provided LAPACK library works.") + set(LATESTLAPACK_FOUND TRUE) endif() endif() @@ -399,6 +314,27 @@ endif() if(NOT LATESTLAPACK_FOUND) message(STATUS "Using supplied NETLIB LAPACK implementation") set(LAPACK_LIBRARIES ${LAPACKLIB}) + + enable_language(Fortran) + + # Check for any necessary platform specific compiler flags + include(CheckLAPACKCompilerFlags) + CheckLAPACKCompilerFlags() + + # Check second function + include(CheckTimeFunction) + set(TIME_FUNC NONE) + CHECK_TIME_FUNCTION(NONE TIME_FUNC) + CHECK_TIME_FUNCTION(INT_CPU_TIME TIME_FUNC) + CHECK_TIME_FUNCTION(EXT_ETIME TIME_FUNC) + CHECK_TIME_FUNCTION(EXT_ETIME_ TIME_FUNC) + CHECK_TIME_FUNCTION(INT_ETIME TIME_FUNC) + + # Set second function + message(STATUS "--> Will use second_${TIME_FUNC}.f and dsecnd_${TIME_FUNC}.f as timing function.") + set(SECOND_SRC ${LAPACK_SOURCE_DIR}/INSTALL/second_${TIME_FUNC}.f) + set(DSECOND_SRC ${LAPACK_SOURCE_DIR}/INSTALL/dsecnd_${TIME_FUNC}.f) + add_subdirectory(SRC) else() set(CMAKE_EXE_LINKER_FLAGS @@ -431,9 +367,11 @@ endif() # Cache export target set(LAPACK_INSTALL_EXPORT_NAME_CACHE ${LAPACK_INSTALL_EXPORT_NAME}) if(BUILD_TESTING OR LAPACKE_WITH_TMG) + enable_language(Fortran) if(LATESTLAPACK_FOUND AND LAPACKE_WITH_TMG) set(CMAKE_REQUIRED_LIBRARIES ${LAPACK_LIBRARIES}) # Check if dlatms (part of tmg) is found + include(CheckFortranFunctionExists) CHECK_FORTRAN_FUNCTION_EXISTS("dlatms" LAPACK_WITH_TMGLIB_FOUND) unset(CMAKE_REQUIRED_LIBRARIES) if(NOT LAPACK_WITH_TMGLIB_FOUND) @@ -448,6 +386,12 @@ endif() set(LAPACK_INSTALL_EXPORT_NAME ${LAPACK_INSTALL_EXPORT_NAME_CACHE}) unset(LAPACK_INSTALL_EXPORT_NAME_CACHE) + +#------------------------------------- +# LAPACKE +# Include lapack.h and lapacke_mangling.h even if LAPACKE is not built +add_subdirectory(LAPACKE/include) + if(LAPACKE) add_subdirectory(LAPACKE) endif() @@ -474,8 +418,8 @@ if (BLAS++) ExternalProject_Add(blaspp URL https://bitbucket.org/icl/blaspp/downloads/blaspp-2020.10.02.tar.gz CONFIGURE_COMMAND ${CMAKE_COMMAND} -E env LIBRARY_PATH=$ENV{LIBRARY_PATH}:${CMAKE_BINARY_DIR}/lib LD_LIBRARY_PATH=$ENV{LD_LIBRARY_PATH}:${PROJECT_BINARY_DIR}/lib ${CMAKE_COMMAND} -DCMAKE_INSTALL_PREFIX=${PROJECT_BINARY_DIR} -DCMAKE_INSTALL_LIBDIR=lib -DBUILD_SHARED_LIBS=${BUILD_SHARED_LIBS} ${PROJECT_BINARY_DIR}/blaspp-prefix/src/blaspp - BUILD_COMMAND ${CMAKE_COMMAND} -E env LIBRARY_PATH=$ENV{LIBRARY_PATH}:${PROJECT_BINARY_DIR}/lib LIB_SUFFIX="" make - INSTALL_COMMAND make PREFIX=${PROJECT_BINARY_DIR} LIB_SUFFIX="" install + BUILD_COMMAND ${CMAKE_COMMAND} -E env LIBRARY_PATH=$ENV{LIBRARY_PATH}:${PROJECT_BINARY_DIR}/lib LIB_SUFFIX="" ${CMAKE_COMMAND} --build . + INSTALL_COMMAND ${CMAKE_COMMAND} -E env PREFIX=${PROJECT_BINARY_DIR} LIB_SUFFIX="" ${CMAKE_COMMAND} --install . ) ExternalProject_Add_StepDependencies(blaspp build ${BLAS_LIBRARIES}) endif() @@ -487,16 +431,16 @@ if (LAPACK++) ExternalProject_Add(lapackpp URL https://bitbucket.org/icl/lapackpp/downloads/lapackpp-2020.10.02.tar.gz CONFIGURE_COMMAND ${CMAKE_COMMAND} -E env LIBRARY_PATH=$ENV{LIBRARY_PATH}:${CMAKE_BINARY_DIR}/lib LD_LIBRARY_PATH=$ENV{LD_LIBRARY_PATH}:${PROJECT_BINARY_DIR}/lib ${CMAKE_COMMAND} -DCMAKE_INSTALL_PREFIX=${PROJECT_BINARY_DIR} -DCMAKE_INSTALL_LIBDIR=lib -DLAPACK_LIBRARIES=${LAPACK_LIBRARIES} -DBUILD_SHARED_LIBS=${BUILD_SHARED_LIBS} ${PROJECT_BINARY_DIR}/lapackpp-prefix/src/lapackpp - BUILD_COMMAND ${CMAKE_COMMAND} -E env LIBRARY_PATH=$ENV{LIBRARY_PATH}:${PROJECT_BINARY_DIR}/lib LIB_SUFFIX="" make - INSTALL_COMMAND make PREFIX=${PROJECT_BINARY_DIR} LIB_SUFFIX="" install + BUILD_COMMAND ${CMAKE_COMMAND} -E env LIBRARY_PATH=$ENV{LIBRARY_PATH}:${PROJECT_BINARY_DIR}/lib LIB_SUFFIX="" ${CMAKE_COMMAND} --build . + INSTALL_COMMAND ${CMAKE_COMMAND} -E env PREFIX=${PROJECT_BINARY_DIR} LIB_SUFFIX="" ${CMAKE_COMMAND} --install . ) else () # FIXME this does not really work as the libraries list gets converted to a semicolon-separated list somewhere in the lapack++ build files ExternalProject_Add(lapackpp URL https://bitbucket.org/icl/lapackpp/downloads/lapackpp-2020.10.02.tar.gz CONFIGURE_COMMAND env LIBRARY_PATH=$ENV{LIBRARY_PATH}:${CMAKE_BINARY_DIR}/lib LD_LIBRARY_PATH=$ENV{LD_LIBRARY_PATH}:${PROJECT_BINARY_DIR}/lib ${CMAKE_COMMAND} -DCMAKE_INSTALL_PREFIX=${PROJECT_BINARY_DIR} -DCMAKE_INSTALL_LIBDIR=lib -DLAPACK_LIBRARIES="${PROJECT_BINARY_DIR}/lib/liblapack.a -lgfortran" -DBUILD_SHARED_LIBS=${BUILD_SHARED_LIBS} ${PROJECT_BINARY_DIR}/lapackpp-prefix/src/lapackpp - BUILD_COMMAND env LIBRARY_PATH=$ENV{LIBRARY_PATH}:${PROJECT_BINARY_DIR}/lib LIB_SUFFIX="" make - INSTALL_COMMAND make PREFIX=${PROJECT_BINARY_DIR} LIB_SUFFIX="" install + BUILD_COMMAND env LIBRARY_PATH=$ENV{LIBRARY_PATH}:${PROJECT_BINARY_DIR}/lib LIB_SUFFIX="" ${CMAKE_COMMAND} --build . + INSTALL_COMMAND ${CMAKE_COMMAND} -E env PREFIX=${PROJECT_BINARY_DIR} LIB_SUFFIX="" ${CMAKE_COMMAND} --install . ) endif() ExternalProject_Add_StepDependencies(lapackpp build blaspp ${BLAS_LIBRARIES} ${LAPACK_LIBRARIES}) @@ -671,22 +615,34 @@ if(BUILD_HTML_DOCUMENTATION OR BUILD_MAN_DOCUMENTATION) set(DOXYGEN_PROJECT_BRIEF "LAPACK: Linear Algebra PACKage") set(DOXYGEN_PROJECT_NUMBER ${LAPACK_VERSION}) set(DOXYGEN_OUTPUT_DIRECTORY ${CMAKE_CURRENT_BINARY_DIR}/DOCS) - set(PROJECT_LOGO ${CMAKE_CURRENT_SOURCE_DIR}/DOCS/lapack.png) + set(DOXYGEN_PROJECT_LOGO ${CMAKE_CURRENT_SOURCE_DIR}/DOCS/lapack.png) set(DOXYGEN_OPTIMIZE_FOR_FORTRAN YES) set(DOXYGEN_SOURCE_BROWSER YES) - set(DISTRIBUTE_GROUP_DOC YES) set(DOXYGEN_CREATE_SUBDIRS YES) set(DOXYGEN_SEPARATE_MEMBER_PAGES YES) set(DOXYGEN_EXTRACT_ALL YES) - set(DOXYGEN_FILE_PATTERNS "*.f;*.c;*.h") + set(DOXYGEN_FILE_PATTERNS *.f *.f90 *.c *.h ) set(DOXYGEN_RECURSIVE YES) set(DOXYGEN_GENERATE_TREEVIEW YES) + set(DOXYGEN_DOT_IMAGE_FORMAT svg) set(DOXYGEN_INTERACTIVE_SVG YES) - set(DOXYGEN_QUIET YES) - set(DOXYGEN_WARNINGS NO) + set(DOXYGEN_QUIET NO) + set(DOXYGEN_WARNINGS YES) + set(DOXYGEN_WARN_NO_PARAMDOC YES) + set(DOXYGEN_WARN_LOGFILE doxygen_error) set(DOXYGEN_GENERATE_HTML NO) set(DOXYGEN_GENERATE_MAN NO) - + set(DOXYGEN_LAYOUT_FILE "DOCS/DoxygenLayout.xml") + + # Exclude functions that are duplicated, creating conflicts. + set(DOXYGEN_EXCLUDE .git + .github + SRC/VARIANTS + BLAS/SRC/lsame.f + BLAS/SRC/xerbla.f + BLAS/SRC/xerbla_array.f + INSTALL/slamchf77.f + INSTALL/dlamchf77.f ) if (BUILD_HTML_DOCUMENTATION) set(DOXYGEN_GENERATE_HTML YES) @@ -697,13 +653,21 @@ if(BUILD_HTML_DOCUMENTATION OR BUILD_MAN_DOCUMENTATION) doxygen_add_docs( html - ${PROJECT_SOURCE_DIR} + + # Doxygen INPUT = + ${PROJECT_SOURCE_DIR}/README.md + ${PROJECT_SOURCE_DIR}/BLAS + ${PROJECT_SOURCE_DIR}/CBLAS + ${PROJECT_SOURCE_DIR}/SRC + ${PROJECT_SOURCE_DIR}/INSTALL + ${PROJECT_SOURCE_DIR}/TESTING + ${PROJECT_SOURCE_DIR}/DOCS/groups-usr.dox + COMMENT "Generating html LAPACK documentation (it will take some time... time to grab a coffee)" ) endif() if (BUILD_MAN_DOCUMENTATION) set(DOXYGEN_GENERATE_MAN YES) - set(DOXYGEN_EXCLUDE SRC/VARIANTS) set(DOXYGEN_MAN_LINKS YES) set(DOXYGEN_INLINE_SOURCES NO) set(DOXYGEN_CALL_GRAPH NO) @@ -711,7 +675,15 @@ if(BUILD_HTML_DOCUMENTATION OR BUILD_MAN_DOCUMENTATION) doxygen_add_docs( man - ${PROJECT_SOURCE_DIR} + + # Doxygen INPUT = + ${PROJECT_SOURCE_DIR}/BLAS + ${PROJECT_SOURCE_DIR}/CBLAS + ${PROJECT_SOURCE_DIR}/SRC + ${PROJECT_SOURCE_DIR}/INSTALL + ${PROJECT_SOURCE_DIR}/TESTING + ${PROJECT_SOURCE_DIR}/DOCS/groups-usr.dox + COMMENT "Generating man LAPACK documentation" ) endif() diff --git a/lapack-netlib/LICENSE b/lapack-netlib/LICENSE index 94cdb0f85..96b04c988 100644 --- a/lapack-netlib/LICENSE +++ b/lapack-netlib/LICENSE @@ -1,9 +1,9 @@ -Copyright (c) 1992-2017 The University of Tennessee and The University +Copyright (c) 1992-2023 The University of Tennessee and The University of Tennessee Research Foundation. All rights reserved. -Copyright (c) 2000-2017 The University of California Berkeley. All +Copyright (c) 2000-2023 The University of California Berkeley. All rights reserved. -Copyright (c) 2006-2017 The University of Colorado Denver. All rights +Copyright (c) 2006-2023 The University of Colorado Denver. All rights reserved. $COPYRIGHT$ diff --git a/lapack-netlib/README.md b/lapack-netlib/README.md index 142aa7b72..a00d4c51d 100644 --- a/lapack-netlib/README.md +++ b/lapack-netlib/README.md @@ -6,7 +6,7 @@ [![Appveyor](https://ci.appveyor.com/api/projects/status/bh38iin398msrbtr?svg=true)](https://ci.appveyor.com/project/langou/lapack/) [![codecov](https://codecov.io/gh/Reference-LAPACK/lapack/branch/master/graph/badge.svg)](https://codecov.io/gh/Reference-LAPACK/lapack) [![Packaging status](https://repology.org/badge/tiny-repos/lapack.svg)](https://repology.org/metapackage/lapack/versions) - +[![OpenSSF Scorecard](https://api.securityscorecards.dev/projects/github.com/Reference-LAPACK/lapack/badge)](https://securityscorecards.dev/viewer/?uri=github.com/Reference-LAPACK/lapack) * VERSION 1.0 : February 29, 1992 * VERSION 1.0a : June 30, 1992 @@ -37,6 +37,7 @@ * VERSION 3.10.0 : June 2021 * VERSION 3.10.1 : April 2022 * VERSION 3.11.0 : November 2022 +* VERSION 3.12.0 : November 2023 LAPACK is a library of Fortran subroutines for solving the most commonly occurring problems in numerical linear algebra. From 9beee55167c80d7fee7aadb78856c27c7d4b4fe2 Mon Sep 17 00:00:00 2001 From: "Kirill A. Korinsky" Date: Mon, 27 Nov 2023 16:54:49 +0000 Subject: [PATCH 27/60] Enable overstep of too long args without DYNAMIC_ARCH --- CMakeLists.txt | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index 69077322a..7c6b96f41 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -249,20 +249,21 @@ if (${CMAKE_SYSTEM_NAME} MATCHES "AIX|Android|Linux|FreeBSD|OpenBSD|NetBSD|Drago endif() endif() -if (APPLE AND DYNAMIC_ARCH AND BUILD_SHARED_LIBS) +# Seems that this hack doesn't required since macOS 11 Big Sur +if (APPLE AND BUILD_SHARED_LIBS AND CMAKE_HOST_SYSTEM_VERSION VERSION_LESS 20) set (CMAKE_C_USE_RESPONSE_FILE_FOR_OBJECTS 1) if (NOT NOFORTRAN) set (CMAKE_Fortran_USE_RESPONSE_FILE_FOR_OBJECTS 1) set (CMAKE_Fortran_CREATE_SHARED_LIBRARY - "sh -c 'cat ${CMAKE_BINARY_DIR}/CMakeFiles/openblas_shared.dir/objects*.rsp | xargs -n 1024 ar -ru libopenblas.a && exit 0' " - "sh -c 'ar -ru libopenblas.a ${CMAKE_BINARY_DIR}/driver/others/CMakeFiles/driver_others.dir/xerbla.c.o && exit 0' " + "sh -c 'cat ${CMAKE_BINARY_DIR}/CMakeFiles/openblas_shared.dir/objects*.rsp | xargs -n 1024 ${CMAKE_AR} -ru libopenblas.a && exit 0' " + "sh -c '${CMAKE_AR} -ru libopenblas.a ${CMAKE_BINARY_DIR}/driver/others/CMakeFiles/driver_others.dir/xerbla.c.o && exit 0' " "sh -c 'echo \"\" | ${CMAKE_Fortran_COMPILER} -o dummy.o -c -x f95-cpp-input - '" "sh -c '${CMAKE_Fortran_COMPILER} -fpic -shared -Wl,-all_load -Wl,-force_load,libopenblas.a -Wl,-noall_load dummy.o -o ${CMAKE_LIBRARY_OUTPUT_DIRECTORY}/libopenblas.${OpenBLAS_MAJOR_VERSION}.${OpenBLAS_MINOR_VERSION}.dylib'" "sh -c 'ls -l ${CMAKE_BINARY_DIR}/lib'") else () set (CMAKE_C_CREATE_SHARED_LIBRARY - "sh -c 'cat ${CMAKE_BINARY_DIR}/CMakeFiles/openblas_shared.dir/objects*.rsp | xargs -n 1024 ar -ru libopenblas.a && exit 0' " - "sh -c 'ar -ru libopenblas.a ${CMAKE_BINARY_DIR}/driver/others/CMakeFiles/driver_others.dir/xerbla.c.o && exit 0' " + "sh -c 'cat ${CMAKE_BINARY_DIR}/CMakeFiles/openblas_shared.dir/objects*.rsp | xargs -n 1024 ${CMAKE_AR} -ru libopenblas.a && exit 0' " + "sh -c '${CMAKE_AR} -ru libopenblas.a ${CMAKE_BINARY_DIR}/driver/others/CMakeFiles/driver_others.dir/xerbla.c.o && exit 0' " "sh -c '${CMAKE_C_COMPILER} -fpic -shared -Wl,-all_load -Wl,-force_load,libopenblas.a -Wl,-noall_load -o ${CMAKE_LIBRARY_OUTPUT_DIRECTORY}/libopenblas.${OpenBLAS_MAJOR_VERSION}.${OpenBLAS_MINOR_VERSION}.dylib'") endif () endif() From ff92e6e7071aa09dcf0f3d7196bdf53d1bbfc422 Mon Sep 17 00:00:00 2001 From: Martin Kroeker Date: Tue, 28 Nov 2023 12:53:35 +0100 Subject: [PATCH 28/60] Fix installation location of lapacke_mangling header --- CMakeLists.txt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index 7c6b96f41..6b02864ca 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -542,7 +542,7 @@ if(NOT NO_LAPACKE) ADD_CUSTOM_TARGET(genlapacke COMMAND ${CMAKE_COMMAND} -E copy ${CMAKE_CURRENT_SOURCE_DIR}/lapack-netlib/LAPACKE/include/lapacke_mangling_with_flags.h.in "${CMAKE_BINARY_DIR}/lapacke_mangling.h" ) - install (FILES ${CMAKE_BINARY_DIR}/lapacke_mangling.h DESTINATION ${CMAKE_INSTALL_INCLUDEDIR}/openblas${SUFFIX64}) + install (FILES ${CMAKE_BINARY_DIR}/lapacke_mangling.h DESTINATION ${CMAKE_INSTALL_INCLUDEDIR}) endif() # Install pkg-config files From 1310a0931bc614d8b8bc211ddb82d72cd64aee43 Mon Sep 17 00:00:00 2001 From: Shiyou Yin Date: Wed, 15 Nov 2023 16:54:06 +0800 Subject: [PATCH 29/60] loongarch: Refine build control for loongarch64. 1. Use getauxval instead of cpucfg to test hardware capability. 2. Remove unnecessary code and option for compiler check in c_check. --- c_check | 6 ++---- c_check.pl | 6 ++---- cpuid_loongarch64.c | 16 +++++++++++----- driver/others/dynamic_loongarch64.c | 19 +++++++------------ 4 files changed, 22 insertions(+), 25 deletions(-) diff --git a/c_check b/c_check index b018c10a8..b5e4a9ad0 100755 --- a/c_check +++ b/c_check @@ -199,8 +199,7 @@ if [ "$architecture" = "loongarch64" ]; then tmpd="$(mktemp -d)" tmplsx="$tmpd/lsx.c" codelsx='"vadd.b $vr0, $vr0, $vr0"' - lsx_flags='-march=loongarch64 -mlsx' - printf "#include \n\n" >> "$tmplsx" + lsx_flags='-march=loongarch64' printf "void main(void){ __asm__ volatile(%s);}\n" "$codelsx" >> "$tmplsx" args="$lsx_flags -o $tmplsx.o $tmplsx" { @@ -211,8 +210,7 @@ if [ "$architecture" = "loongarch64" ]; then tmplasx="$tmpd/lasx.c" codelasx='"xvadd.b $xr0, $xr0, $xr0"' - lasx_flags='-march=loongarch64 -mlasx' - printf "#include \n\n" >> "$tmplasx" + lasx_flags='-march=loongarch64' printf "void main(void){ __asm__ volatile(%s);}\n" "$codelasx" >> "$tmplasx" args="$lasx_flags -o $tmplasx.o $tmplasx" { diff --git a/c_check.pl b/c_check.pl index 7a860a211..d9c36793c 100644 --- a/c_check.pl +++ b/c_check.pl @@ -241,8 +241,7 @@ if (($architecture eq "loongarch64")) { } else { $tmplsx = new File::Temp( SUFFIX => '.c' , UNLINK => 1 ); $codelsx = '"vadd.b $vr0, $vr0, $vr0"'; - $lsx_flags = "-march=loongarch64 -mlsx"; - print $tmplsx "#include \n\n"; + $lsx_flags = "-march=loongarch64"; print $tmplsx "void main(void){ __asm__ volatile($codelsx); }\n"; $args = "$lsx_flags -o $tmplsx.o $tmplsx"; @@ -257,8 +256,7 @@ if (($architecture eq "loongarch64")) { $tmplasx = new File::Temp( SUFFIX => '.c' , UNLINK => 1 ); $codelasx = '"xvadd.b $xr0, $xr0, $xr0"'; - $lasx_flags = "-march=loongarch64 -mlasx"; - print $tmplasx "#include \n\n"; + $lasx_flags = "-march=loongarch64"; print $tmplasx "void main(void){ __asm__ volatile($codelasx); }\n"; $args = "$lasx_flags -o $tmplasx.o $tmplasx"; diff --git a/cpuid_loongarch64.c b/cpuid_loongarch64.c index 7c389db27..0ad32ae4e 100644 --- a/cpuid_loongarch64.c +++ b/cpuid_loongarch64.c @@ -47,8 +47,8 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #define CPU_LOONGSON3R5 1 #define CPU_LOONGSON2K1000 2 -#define LA_HWCAP_LSX (1<<4) -#define LA_HWCAP_LASX (1<<5) +#define LA_HWCAP_LSX (1U << 4) +#define LA_HWCAP_LASX (1U << 5) static char *cpuname[] = { "LOONGSONGENERIC", @@ -64,11 +64,11 @@ static char *cpuname_lower[] = { int detect(void) { #ifdef __linux - int flag = (int)getauxval(AT_HWCAP); + int hwcap = (int)getauxval(AT_HWCAP); - if (flag & LA_HWCAP_LASX) + if (hwcap & LA_HWCAP_LASX) return CPU_LOONGSON3R5; - else if (flag & LA_HWCAP_LSX) + else if (hwcap & LA_HWCAP_LSX) return CPU_LOONGSON2K1000; else return CPU_GENERIC; @@ -94,7 +94,9 @@ void get_subdirname(void) { } void get_cpuconfig(void) { + uint32_t hwcaps = 0; int d = detect(); + switch (d) { case CPU_LOONGSON3R5: printf("#define LOONGSON3R5\n"); @@ -129,6 +131,10 @@ void get_cpuconfig(void) { printf("#define L2_ASSOCIATIVE 16\n"); break; } + + hwcaps = (uint32_t)getauxval( AT_HWCAP ); + if (hwcaps & LA_HWCAP_LSX) printf("#define HAVE_LSX\n"); + if (hwcaps & LA_HWCAP_LASX) printf("#define HAVE_LASX\n"); } void get_libname(void){ diff --git a/driver/others/dynamic_loongarch64.c b/driver/others/dynamic_loongarch64.c index 52f8bcb2f..44de59669 100644 --- a/driver/others/dynamic_loongarch64.c +++ b/driver/others/dynamic_loongarch64.c @@ -25,6 +25,7 @@ OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *******************************************************************************/ +#include #include "common.h" extern gotoblas_t gotoblas_LOONGSON3R5; @@ -74,21 +75,15 @@ static gotoblas_t *force_coretype(char *coretype) { return NULL; } -#define LASX_MASK 1<<7 -#define LSX_MASK 1<<6 -#define LOONGARCH_CFG2 0x02 +#define LA_HWCAP_LSX (1U << 4) +#define LA_HWCAP_LASX (1U << 5) static gotoblas_t *get_coretype(void) { - int ret = 0; - __asm__ volatile ( - "cpucfg %0, %1 \n\t" - : "+&r"(ret) - : "r"(LOONGARCH_CFG2) - ); - - if (ret & LASX_MASK) + int hwcap = (int)getauxval(AT_HWCAP); + + if (hwcap & LA_HWCAP_LASX) return &gotoblas_LOONGSON3R5; - else if (ret & LSX_MASK) + else if (hwcap & LA_HWCAP_LSX) return &gotoblas_LOONGSON2K1000; else return &gotoblas_LOONGSONGENERIC; From 3def6a8143253a7b3c5b6477d803ecdb1165bfbc Mon Sep 17 00:00:00 2001 From: Shiyou Yin Date: Wed, 15 Nov 2023 17:24:33 +0800 Subject: [PATCH 30/60] loongarch: Add LASX optimization for dot. --- common_loongarch64.h | 19 ++ kernel/loongarch64/KERNEL.LOONGSON2K1000 | 0 kernel/loongarch64/KERNEL.LOONGSON3R5 | 4 + kernel/loongarch64/dot_lasx.S | 309 +++++++++++++++++++++++ 4 files changed, 332 insertions(+) create mode 100644 kernel/loongarch64/KERNEL.LOONGSON2K1000 create mode 100644 kernel/loongarch64/dot_lasx.S diff --git a/common_loongarch64.h b/common_loongarch64.h index ce1fcf091..4963b2f07 100644 --- a/common_loongarch64.h +++ b/common_loongarch64.h @@ -124,7 +124,17 @@ static inline int WhereAmI(void){ #define CMPLE fcmp.cle.d #define CMPLT fcmp.clt.d #define NEG fneg.d + +#define XVFSUB xvfsub.d +#define XVFADD xvfadd.d +#define XVFMADD xvfmadd.d + +#define VFSUB vfsub.d +#define VFADD vfadd.d +#define VFMADD vfmadd.d + #else + #define LD fld.s #define ST fst.s #define MADD fmadd.s @@ -142,6 +152,15 @@ static inline int WhereAmI(void){ #define CMPLE fcmp.cle.s #define CMPLT fcmp.clt.s #define NEG fneg.s + +#define XVFSUB xvfsub.s +#define XVFADD xvfadd.s +#define XVFMADD xvfmadd.s + +#define VFSUB vfsub.s +#define VFADD vfadd.s +#define VFMADD vfmadd.s + #endif /* defined(DOUBLE) */ #if defined(__64BIT__) && defined(USE64BITINT) diff --git a/kernel/loongarch64/KERNEL.LOONGSON2K1000 b/kernel/loongarch64/KERNEL.LOONGSON2K1000 new file mode 100644 index 000000000..e69de29bb diff --git a/kernel/loongarch64/KERNEL.LOONGSON3R5 b/kernel/loongarch64/KERNEL.LOONGSON3R5 index 011e8b89e..d1b93b0ca 100644 --- a/kernel/loongarch64/KERNEL.LOONGSON3R5 +++ b/kernel/loongarch64/KERNEL.LOONGSON3R5 @@ -1,4 +1,8 @@ ifndef NO_LASX + +SDOTKERNEL = dot_lasx.S +DDOTKERNEL = dot_lasx.S + DGEMMKERNEL = dgemm_kernel_16x4.S DGEMMINCOPY = dgemm_ncopy_16.S DGEMMITCOPY = dgemm_tcopy_16.S diff --git a/kernel/loongarch64/dot_lasx.S b/kernel/loongarch64/dot_lasx.S new file mode 100644 index 000000000..9d3cbf63d --- /dev/null +++ b/kernel/loongarch64/dot_lasx.S @@ -0,0 +1,309 @@ +/*************************************************************************** +Copyright (c) 2023, The OpenBLAS Project +All rights reserved. +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: +1. Redistributions of source code must retain the above copyright +notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright +notice, this list of conditions and the following disclaimer in +the documentation and/or other materials provided with the +distribution. +3. Neither the name of the OpenBLAS project nor the names of +its contributors may be used to endorse or promote products +derived from this software without specific prior written permission. +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE OPENBLAS PROJECT OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE +USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +*****************************************************************************/ + +#define ASSEMBLER + +#include "common.h" + +#define N $r4 +#define X $r5 +#define INCX $r6 +#define Y $r7 +#define INCY $r8 + +#define I $r17 +#define TEMP $r18 + +/* Don't change following FR unless you know the effects. */ +#define s1 $f8 +#define s2 $f9 +#define a1 $f10 +#define b1 $f11 + +PROLOGUE + +#ifdef F_INTERFACE + LDINT N, 0(N) + LDINT INCX, 0(INCX) + LDINT INCY, 0(INCY) +#endif + SUB s1, s1, s1 + SUB s2, s2, s2 + slli.d INCX, INCX, BASE_SHIFT + li.d TEMP, SIZE + slli.d INCY, INCY, BASE_SHIFT + bge $r0, N, .L999 + bne INCX, TEMP, .L20 /* inc_x=1 */ + bne INCY, TEMP, .L20 /* inc_y=1 */ +#ifdef DOUBLE + srai.d I, N, 4 +#else + srai.d I, N, 5 +#endif + + /* init $xr8 and $xr9 to zero */ +#ifdef DOUBLE + xvldrepl.d $xr0, X, 0 +#else + xvldrepl.w $xr0, X, 0 +#endif + XVFSUB $xr8, $xr0, $xr0 + XVFSUB $xr9, $xr0, $xr0 + +/* !((inc_x == 1) && (inc_y == 1)) */ + bge $r0, I, .L12 /* <32 */ +.L11: + /* case 32~ */ + xvld $xr0, X, 0 + xvld $xr1, X, 32 + xvld $xr2, X, 64 + xvld $xr3, X, 96 + xvld $xr4, Y, 0 + xvld $xr5, Y, 32 + xvld $xr6, Y, 64 + xvld $xr7, Y, 96 + addi.w I, I, -1 + addi.d X, X, 128 + addi.d Y, Y, 128 + XVFMADD $xr8, $xr0, $xr4, $xr8 + XVFMADD $xr9, $xr1, $xr5, $xr9 + XVFMADD $xr8, $xr2, $xr6, $xr8 + XVFMADD $xr9, $xr3, $xr7, $xr9 + bnez I, .L11 +.L12: +#ifdef DOUBLE + andi I, N, 0xf + srai.d I, I, 2 +#else + andi I, N, 0x1f + srai.d I, I, 3 +#endif + bge $r0, I, .L14 /* <8 */ +.L13: + /* case 8~31 */ + xvld $xr0, X, 0 + xvld $xr4, Y, 0 + addi.w I, I, -1 + addi.d X, X, 32 + addi.d Y, Y, 32 + XVFMADD $xr8, $xr0, $xr4, $xr8 + bnez I, .L13 +.L14: + /* store dot in s1 $f8 */ + XVFADD $xr8, $xr8, $xr9 + SUB s2, s2, s2 /* set s2 to 0.0 */ + xvpermi.q $xr0, $xr8, 0x1 + VFADD $vr8, $vr8, $vr0 + vpackod.d $vr0, $vr8, $vr8 +#ifdef DOUBLE + VFADD $vr8, $vr8, $vr0 +#else + VFADD $vr8, $vr8, $vr0 + vpackod.w $vr0, $vr8, $vr8 + VFADD $vr8, $vr8, $vr0 +#endif +.L15: +#ifdef DOUBLE + andi I, N, 0x3 +#else + andi I, N, 0x7 +#endif + bge $r0, I, .L999 /* =0 */ + .align 3 +.L16: + /* case 1~7 */ + LD a1, X, 0 + LD b1, Y, 0 +#ifdef DSDOT + fcvt.d.s a1, a1 + fcvt.d.s b1, b1 + fmadd.d s1, b1, a1, s1 +#else + MADD s1, b1, a1, s1 +#endif + addi.d I, I, -1 + addi.d X, X, SIZE + addi.d Y, Y, SIZE + bnez I, .L16 + b .L999 + .align 3 + +.L20: +/* !((inc_x == 1) && (inc_y == 1)) */ + srai.d I, N, 3 +#ifdef F_INTERFACE + bgez INCX, .L21 + addi.d TEMP, N, -1 + mult TEMP, INCX + mflo TEMP + dsub X, X, TEMP + .align 3 + +.L21: + bgez INCY, .L22 + addi.d TEMP, N, -1 + mult TEMP, INCY + mflo TEMP + dsub Y, Y, TEMP + .align 3 + +.L22: +#endif + bge $r0, I, .L25 /* <8 */ + .align 3 + +.L23: + LD a1, X, 0 * SIZE + add.d X, X, INCX + LD b1, Y, 0 * SIZE + add.d Y, Y, INCY +#ifdef DSDOT + fcvt.d.s a1, a1 + fcvt.d.s b1, b1 + fmadd.d s1, b1, a1, s1 +#else + MADD s1, b1, a1, s1 +#endif + + LD a1, X, 0 * SIZE + add.d X, X, INCX + LD b1, Y, 0 * SIZE + add.d Y, Y, INCY +#ifdef DSDOT + fcvt.d.s a1, a1 + fcvt.d.s b1, b1 + fmadd.d s2, b1, a1, s2 +#else + MADD s2, b1, a1, s2 +#endif + + LD a1, X, 0 * SIZE + add.d X, X, INCX + LD b1, Y, 0 * SIZE + add.d Y, Y, INCY +#ifdef DSDOT + fcvt.d.s a1, a1 + fcvt.d.s b1, b1 + fmadd.d s1, b1, a1, s1 +#else + MADD s1, b1, a1, s1 +#endif + + LD a1, X, 0 * SIZE + add.d X, X, INCX + LD b1, Y, 0 * SIZE + add.d Y, Y, INCY +#ifdef DSDOT + fcvt.d.s a1, a1 + fcvt.d.s b1, b1 + fmadd.d s2, b1, a1, s2 +#else + MADD s2, b1, a1, s2 +#endif + + LD a1, X, 0 * SIZE + add.d X, X, INCX + LD b1, Y, 0 * SIZE + add.d Y, Y, INCY +#ifdef DSDOT + fcvt.d.s a1, a1 + fcvt.d.s b1, b1 + fmadd.d s1, b1, a1, s1 +#else + MADD s1, b1, a1, s1 +#endif + + LD a1, X, 0 * SIZE + add.d X, X, INCX + LD b1, Y, 0 * SIZE + add.d Y, Y, INCY +#ifdef DSDOT + fcvt.d.s a1, a1 + fcvt.d.s b1, b1 + fmadd.d s2, b1, a1, s2 +#else + MADD s2, b1, a1, s2 +#endif + + LD a1, X, 0 * SIZE + add.d X, X, INCX + LD b1, Y, 0 * SIZE + add.d Y, Y, INCY +#ifdef DSDOT + fcvt.d.s a1, a1 + fcvt.d.s b1, b1 + fmadd.d s1, b1, a1, s1 +#else + MADD s1, b1, a1, s1 +#endif + + LD a1, X, 0 * SIZE + add.d X, X, INCX + LD b1, Y, 0 * SIZE + add.d Y, Y, INCY + addi.d I, I, -1 +#ifdef DSDOT + fcvt.d.s a1, a1 + fcvt.d.s b1, b1 + fmadd.d s2, b1, a1, s2 +#else + MADD s2, b1, a1, s2 +#endif + blt $r0, I, .L23 + .align 3 + +.L25: + andi I, N, 7 + bge $r0, I, .L999 + .align 3 + +.L26: + LD a1, X, 0 * SIZE + add.d X, X, INCX + LD b1, Y, 0 * SIZE + add.d Y, Y, INCY + addi.d I, I, -1 +#ifdef DSDOT + fcvt.d.s a1, a1 + fcvt.d.s b1, b1 + fmadd.d s1, b1, a1, s1 +#else + MADD s1, b1, a1, s1 +#endif + blt $r0, I, .L26 + .align 3 + +.L999: +#ifdef DSDOT + fadd.d $f0, s1, s2 +#else + ADD $f0, s1, s2 +#endif + move $r4, $r17 + jirl $r0, $r1, 0x0 + +EPILOGUE From 13b8c44b44f7fc2eea4f1839b034802a8b1edcae Mon Sep 17 00:00:00 2001 From: Shiyou Yin Date: Fri, 24 Nov 2023 16:40:32 +0800 Subject: [PATCH 31/60] loongarch: Add optimization for dsdot kernel. --- kernel/loongarch64/KERNEL.LOONGSON3R5 | 5 +- kernel/loongarch64/dot_lasx.S | 83 +++++++++++++++++++++++---- 2 files changed, 74 insertions(+), 14 deletions(-) diff --git a/kernel/loongarch64/KERNEL.LOONGSON3R5 b/kernel/loongarch64/KERNEL.LOONGSON3R5 index d1b93b0ca..020a82303 100644 --- a/kernel/loongarch64/KERNEL.LOONGSON3R5 +++ b/kernel/loongarch64/KERNEL.LOONGSON3R5 @@ -1,7 +1,8 @@ ifndef NO_LASX -SDOTKERNEL = dot_lasx.S -DDOTKERNEL = dot_lasx.S +SDOTKERNEL = dot_lasx.S +DSDOTKERNEL = dot_lasx.S +DDOTKERNEL = dot_lasx.S DGEMMKERNEL = dgemm_kernel_16x4.S DGEMMINCOPY = dgemm_ncopy_16.S diff --git a/kernel/loongarch64/dot_lasx.S b/kernel/loongarch64/dot_lasx.S index 9d3cbf63d..0715b6311 100644 --- a/kernel/loongarch64/dot_lasx.S +++ b/kernel/loongarch64/dot_lasx.S @@ -51,6 +51,8 @@ PROLOGUE LDINT INCX, 0(INCX) LDINT INCY, 0(INCY) #endif + + /* init $f8 and $f9 to zero */ SUB s1, s1, s1 SUB s2, s2, s2 slli.d INCX, INCX, BASE_SHIFT @@ -59,11 +61,8 @@ PROLOGUE bge $r0, N, .L999 bne INCX, TEMP, .L20 /* inc_x=1 */ bne INCY, TEMP, .L20 /* inc_y=1 */ -#ifdef DOUBLE - srai.d I, N, 4 -#else - srai.d I, N, 5 -#endif + + /* !((inc_x == 1) && (inc_y == 1)) */ /* init $xr8 and $xr9 to zero */ #ifdef DOUBLE @@ -71,13 +70,24 @@ PROLOGUE #else xvldrepl.w $xr0, X, 0 #endif +#ifdef DSDOT + xvfcvtl.d.s $xr0, $xr0 + xvfsub.d $xr8, $xr0, $xr0 + xvfsub.d $xr9, $xr0, $xr0 +#else XVFSUB $xr8, $xr0, $xr0 XVFSUB $xr9, $xr0, $xr0 +#endif -/* !((inc_x == 1) && (inc_y == 1)) */ - bge $r0, I, .L12 /* <32 */ +#ifdef DOUBLE + srai.d I, N, 4 +#else + srai.d I, N, 5 +#endif + bge $r0, I, .L12 /* FLOAT: <32 ; DOUBLE: <16 */ + .align 3 .L11: - /* case 32~ */ + /* FLOAT: 32~ ; DOUBLE: 16~ */ xvld $xr0, X, 0 xvld $xr1, X, 32 xvld $xr2, X, 64 @@ -89,11 +99,39 @@ PROLOGUE addi.w I, I, -1 addi.d X, X, 128 addi.d Y, Y, 128 +#ifdef DSDOT + xvfcvtl.d.s $xr10, $xr0 + xvfcvtl.d.s $xr11, $xr4 + xvfcvth.d.s $xr12, $xr0 + xvfcvth.d.s $xr13, $xr4 + xvfmadd.d $xr8, $xr10, $xr12, $xr8 + xvfmadd.d $xr9, $xr11, $xr13, $xr9 + xvfcvtl.d.s $xr10, $xr1 + xvfcvtl.d.s $xr11, $xr5 + xvfcvth.d.s $xr12, $xr1 + xvfcvth.d.s $xr13, $xr5 + xvfmadd.d $xr8, $xr10, $xr12, $xr8 + xvfmadd.d $xr9, $xr11, $xr13, $xr9 + xvfcvtl.d.s $xr10, $xr2 + xvfcvtl.d.s $xr11, $xr6 + xvfcvth.d.s $xr12, $xr2 + xvfcvth.d.s $xr13, $xr6 + xvfmadd.d $xr8, $xr10, $xr12, $xr8 + xvfmadd.d $xr9, $xr11, $xr13, $xr9 + xvfcvtl.d.s $xr10, $xr3 + xvfcvtl.d.s $xr11, $xr7 + xvfcvth.d.s $xr12, $xr3 + xvfcvth.d.s $xr13, $xr7 + xvfmadd.d $xr8, $xr10, $xr12, $xr8 + xvfmadd.d $xr9, $xr11, $xr13, $xr9 +#else XVFMADD $xr8, $xr0, $xr4, $xr8 XVFMADD $xr9, $xr1, $xr5, $xr9 XVFMADD $xr8, $xr2, $xr6, $xr8 XVFMADD $xr9, $xr3, $xr7, $xr9 +#endif bnez I, .L11 + .align 3 .L12: #ifdef DOUBLE andi I, N, 0xf @@ -102,18 +140,37 @@ PROLOGUE andi I, N, 0x1f srai.d I, I, 3 #endif - bge $r0, I, .L14 /* <8 */ + bge $r0, I, .L14 /* DOUBLE: <4 ; FLOAT: <8 */ + .align 3 .L13: - /* case 8~31 */ + /* FLOAT: 8~31 ; DOUBLE: 4~15 */ xvld $xr0, X, 0 xvld $xr4, Y, 0 addi.w I, I, -1 addi.d X, X, 32 addi.d Y, Y, 32 +#ifdef DSDOT + xvfcvtl.d.s $xr10, $xr0 + xvfcvtl.d.s $xr11, $xr4 + xvfcvth.d.s $xr12, $xr0 + xvfcvth.d.s $xr13, $xr4 + xvfmadd.d $xr8, $xr10, $xr12, $xr8 + xvfmadd.d $xr9, $xr11, $xr13, $xr9 +#else XVFMADD $xr8, $xr0, $xr4, $xr8 +#endif bnez I, .L13 + .align 3 .L14: /* store dot in s1 $f8 */ +#ifdef DSDOT + xvfadd.d $xr8, $xr8, $xr9 + fsub.s s2, s2, s2, /* set s2 to 0.0 */ + xvpermi.q $xr0, $xr8, 0x1 + vfadd.d $vr8, $vr8, $vr0 + vpackod.d $vr0, $vr8, $vr8 + vfadd.d $vr8, $vr8, $vr0 +#else XVFADD $xr8, $xr8, $xr9 SUB s2, s2, s2 /* set s2 to 0.0 */ xvpermi.q $xr0, $xr8, 0x1 @@ -125,7 +182,9 @@ PROLOGUE VFADD $vr8, $vr8, $vr0 vpackod.w $vr0, $vr8, $vr8 VFADD $vr8, $vr8, $vr0 -#endif +#endif /* defined DOUBLE */ +#endif /* defined DSDOT */ + .align 3 .L15: #ifdef DOUBLE andi I, N, 0x3 @@ -135,7 +194,7 @@ PROLOGUE bge $r0, I, .L999 /* =0 */ .align 3 .L16: - /* case 1~7 */ + /* FLOAT: 1~7 ; DOUBLE: 1~3 */ LD a1, X, 0 LD b1, Y, 0 #ifdef DSDOT From 9fe07d82fdeb4c2d81bdf57415ce1db157109bb1 Mon Sep 17 00:00:00 2001 From: Shiyou Yin Date: Fri, 24 Nov 2023 17:57:14 +0800 Subject: [PATCH 32/60] loongarch: Add LSX optimization for dot. --- kernel/loongarch64/KERNEL.LOONGSON2K1000 | 7 + kernel/loongarch64/dot_lsx.S | 364 +++++++++++++++++++++++ 2 files changed, 371 insertions(+) create mode 100644 kernel/loongarch64/dot_lsx.S diff --git a/kernel/loongarch64/KERNEL.LOONGSON2K1000 b/kernel/loongarch64/KERNEL.LOONGSON2K1000 index e69de29bb..b2a396674 100644 --- a/kernel/loongarch64/KERNEL.LOONGSON2K1000 +++ b/kernel/loongarch64/KERNEL.LOONGSON2K1000 @@ -0,0 +1,7 @@ +ifndef NO_LSX + +SDOTKERNEL = dot_lsx.S +DSDOTKERNEL = dot_lsx.S +DDOTKERNEL = dot_lsx.S + +endif diff --git a/kernel/loongarch64/dot_lsx.S b/kernel/loongarch64/dot_lsx.S new file mode 100644 index 000000000..f7f613553 --- /dev/null +++ b/kernel/loongarch64/dot_lsx.S @@ -0,0 +1,364 @@ +/*************************************************************************** +Copyright (c) 2023, The OpenBLAS Project +All rights reserved. +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: +1. Redistributions of source code must retain the above copyright +notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright +notice, this list of conditions and the following disclaimer in +the documentation and/or other materials provided with the +distribution. +3. Neither the name of the OpenBLAS project nor the names of +its contributors may be used to endorse or promote products +derived from this software without specific prior written permission. +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE OPENBLAS PROJECT OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE +USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +*****************************************************************************/ + +#define ASSEMBLER + +#include "common.h" + +#define N $r4 +#define X $r5 +#define INCX $r6 +#define Y $r7 +#define INCY $r8 + +#define I $r17 +#define TEMP $r18 + +/* Don't change following FR unless you know the effects. */ +#define s1 $f8 +#define s2 $f9 +#define a1 $f10 +#define b1 $f11 + +PROLOGUE + +#ifdef F_INTERFACE + LDINT N, 0(N) + LDINT INCX, 0(INCX) + LDINT INCY, 0(INCY) +#endif + + /* init $f8 and $f9 to zero */ + SUB s1, s1, s1 + SUB s2, s2, s2 + slli.d INCX, INCX, BASE_SHIFT + li.d TEMP, SIZE + slli.d INCY, INCY, BASE_SHIFT + bge $r0, N, .L999 + bne INCX, TEMP, .L20 /* inc_x=1 */ + bne INCY, TEMP, .L20 /* inc_y=1 */ + + /* !((inc_x == 1) && (inc_y == 1)) */ + + /* init $vr8 and $vr9 to zero */ +#ifdef DOUBLE + vldrepl.d $vr0, X, 0 +#else + vldrepl.w $vr0, X, 0 +#endif +#ifdef DSDOT + vfcvtl.d.s $vr0, $vr0 + vfsub.d $vr8, $vr0, $vr0 + vfsub.d $vr9, $vr0, $vr0 +#else + VFSUB $vr8, $vr0, $vr0 + VFSUB $vr9, $vr0, $vr0 +#endif + +#ifdef DOUBLE + srai.d I, N, 3 +#else + srai.d I, N, 4 +#endif + bge $r0, I, .L12 /* FLOAT: <16 ; DOUBLE: <8 */ + .align 3 +.L11: + /* FLOAT: 16~ ; DOUBLE: 8~ */ + vld $vr0, X, 0 + vld $vr1, X, 16 + vld $vr2, X, 32 + vld $vr3, X, 48 + vld $vr4, Y, 0 + vld $vr5, Y, 16 + vld $vr6, Y, 32 + vld $vr7, Y, 48 + addi.w I, I, -1 + addi.d X, X, 64 + addi.d Y, Y, 64 +#ifdef DSDOT + vfcvtl.d.s $vr10, $vr0 + vfcvtl.d.s $vr11, $vr4 + vfcvth.d.s $vr12, $vr0 + vfcvth.d.s $vr13, $vr4 + vfmadd.d $vr8, $vr10, $vr12, $vr8 + vfmadd.d $vr9, $vr11, $vr13, $vr9 + vfcvtl.d.s $vr10, $vr1 + vfcvtl.d.s $vr11, $vr5 + vfcvth.d.s $vr12, $vr1 + vfcvth.d.s $vr13, $vr5 + vfmadd.d $vr8, $vr10, $vr12, $vr8 + vfmadd.d $vr9, $vr11, $vr13, $vr9 + vfcvtl.d.s $vr10, $vr2 + vfcvtl.d.s $vr11, $vr6 + vfcvth.d.s $vr12, $vr2 + vfcvth.d.s $vr13, $vr6 + vfmadd.d $vr8, $vr10, $vr12, $vr8 + vfmadd.d $vr9, $vr11, $vr13, $vr9 + vfcvtl.d.s $vr10, $vr3 + vfcvtl.d.s $vr11, $vr7 + vfcvth.d.s $vr12, $vr3 + vfcvth.d.s $vr13, $vr7 + vfmadd.d $vr8, $vr10, $vr12, $vr8 + vfmadd.d $vr9, $vr11, $vr13, $vr9 +#else + VFMADD $vr8, $vr0, $vr4, $vr8 + VFMADD $vr9, $vr1, $vr5, $vr9 + VFMADD $vr8, $vr2, $vr6, $vr8 + VFMADD $vr9, $vr3, $vr7, $vr9 +#endif + bnez I, .L11 + .align 3 +.L12: +#ifdef DOUBLE + andi I, N, 0x7 + srai.d I, I, 1 +#else + andi I, N, 0xf + srai.d I, I, 2 +#endif + bge $r0, I, .L14 /* DOUBLE: <2 ; FLOAT: <4 */ + .align 3 +.L13: + /* FLOAT: 4~15 ; DOUBLE: 2~7 */ + vld $vr0, X, 0 + vld $vr4, Y, 0 + addi.w I, I, -1 + addi.d X, X, 16 + addi.d Y, Y, 16 +#ifdef DSDOT + vfcvtl.d.s $vr10, $vr0 + vfcvtl.d.s $vr11, $vr4 + vfcvth.d.s $vr12, $vr0 + vfcvth.d.s $vr13, $vr4 + vfmadd.d $vr8, $vr10, $vr12, $vr8 + vfmadd.d $vr9, $vr11, $vr13, $vr9 +#else + VFMADD $vr8, $vr0, $vr4, $vr8 +#endif + bnez I, .L13 + .align 3 +.L14: + /* store dot in s1 $f8 */ +#ifdef DSDOT + vfadd.d $vr8, $vr8, $vr9 + fsub.s s2, s2, s2, /* set s2 to 0.0 */ + vpackod.d $vr0, $vr8, $vr8 + vfadd.d $vr8, $vr8, $vr0 +#else + VFADD $vr8, $vr8, $vr9 + SUB s2, s2, s2 /* set s2 to 0.0 */ + vpackod.d $vr0, $vr8, $vr8 +#ifdef DOUBLE + VFADD $vr8, $vr8, $vr0 +#else + VFADD $vr8, $vr8, $vr0 + vpackod.w $vr0, $vr8, $vr8 + VFADD $vr8, $vr8, $vr0 +#endif /* defined DOUBLE */ +#endif /* defined DSDOT */ + .align 3 +.L15: +#ifdef DOUBLE + andi I, N, 0x1 +#else + andi I, N, 0x3 +#endif + bge $r0, I, .L999 /* =0 */ + .align 3 +.L16: + /* DOUBLE: 1 ; FLOAT: 1~3 */ + LD a1, X, 0 + LD b1, Y, 0 +#ifdef DSDOT + fcvt.d.s a1, a1 + fcvt.d.s b1, b1 + fmadd.d s1, b1, a1, s1 +#else + MADD s1, b1, a1, s1 +#endif + addi.d I, I, -1 + addi.d X, X, SIZE + addi.d Y, Y, SIZE + bnez I, .L16 + b .L999 + .align 3 + +.L20: +/* !((inc_x == 1) && (inc_y == 1)) */ + srai.d I, N, 3 +#ifdef F_INTERFACE + bgez INCX, .L21 + addi.d TEMP, N, -1 + mult TEMP, INCX + mflo TEMP + dsub X, X, TEMP + .align 3 + +.L21: + bgez INCY, .L22 + addi.d TEMP, N, -1 + mult TEMP, INCY + mflo TEMP + dsub Y, Y, TEMP + .align 3 + +.L22: +#endif + bge $r0, I, .L25 /* <8 */ + .align 3 + +.L23: + LD a1, X, 0 * SIZE + add.d X, X, INCX + LD b1, Y, 0 * SIZE + add.d Y, Y, INCY +#ifdef DSDOT + fcvt.d.s a1, a1 + fcvt.d.s b1, b1 + fmadd.d s1, b1, a1, s1 +#else + MADD s1, b1, a1, s1 +#endif + + LD a1, X, 0 * SIZE + add.d X, X, INCX + LD b1, Y, 0 * SIZE + add.d Y, Y, INCY +#ifdef DSDOT + fcvt.d.s a1, a1 + fcvt.d.s b1, b1 + fmadd.d s2, b1, a1, s2 +#else + MADD s2, b1, a1, s2 +#endif + + LD a1, X, 0 * SIZE + add.d X, X, INCX + LD b1, Y, 0 * SIZE + add.d Y, Y, INCY +#ifdef DSDOT + fcvt.d.s a1, a1 + fcvt.d.s b1, b1 + fmadd.d s1, b1, a1, s1 +#else + MADD s1, b1, a1, s1 +#endif + + LD a1, X, 0 * SIZE + add.d X, X, INCX + LD b1, Y, 0 * SIZE + add.d Y, Y, INCY +#ifdef DSDOT + fcvt.d.s a1, a1 + fcvt.d.s b1, b1 + fmadd.d s2, b1, a1, s2 +#else + MADD s2, b1, a1, s2 +#endif + + LD a1, X, 0 * SIZE + add.d X, X, INCX + LD b1, Y, 0 * SIZE + add.d Y, Y, INCY +#ifdef DSDOT + fcvt.d.s a1, a1 + fcvt.d.s b1, b1 + fmadd.d s1, b1, a1, s1 +#else + MADD s1, b1, a1, s1 +#endif + + LD a1, X, 0 * SIZE + add.d X, X, INCX + LD b1, Y, 0 * SIZE + add.d Y, Y, INCY +#ifdef DSDOT + fcvt.d.s a1, a1 + fcvt.d.s b1, b1 + fmadd.d s2, b1, a1, s2 +#else + MADD s2, b1, a1, s2 +#endif + + LD a1, X, 0 * SIZE + add.d X, X, INCX + LD b1, Y, 0 * SIZE + add.d Y, Y, INCY +#ifdef DSDOT + fcvt.d.s a1, a1 + fcvt.d.s b1, b1 + fmadd.d s1, b1, a1, s1 +#else + MADD s1, b1, a1, s1 +#endif + + LD a1, X, 0 * SIZE + add.d X, X, INCX + LD b1, Y, 0 * SIZE + add.d Y, Y, INCY + addi.d I, I, -1 +#ifdef DSDOT + fcvt.d.s a1, a1 + fcvt.d.s b1, b1 + fmadd.d s2, b1, a1, s2 +#else + MADD s2, b1, a1, s2 +#endif + blt $r0, I, .L23 + .align 3 + +.L25: + andi I, N, 7 + bge $r0, I, .L999 + .align 3 + +.L26: + LD a1, X, 0 * SIZE + add.d X, X, INCX + LD b1, Y, 0 * SIZE + add.d Y, Y, INCY + addi.d I, I, -1 +#ifdef DSDOT + fcvt.d.s a1, a1 + fcvt.d.s b1, b1 + fmadd.d s1, b1, a1, s1 +#else + MADD s1, b1, a1, s1 +#endif + blt $r0, I, .L26 + .align 3 + +.L999: +#ifdef DSDOT + fadd.d $f0, s1, s2 +#else + ADD $f0, s1, s2 +#endif + move $r4, $r17 + jirl $r0, $r1, 0x0 + +EPILOGUE From a1562e4baec6ead6a4c4263fb6d22d5d35f7394e Mon Sep 17 00:00:00 2001 From: "Kirill A. Korinsky" Date: Tue, 28 Nov 2023 14:04:01 +0000 Subject: [PATCH 33/60] Allow weak linking on old macOS --- CMakeLists.txt | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index 7c6b96f41..7e5d1e0fb 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -258,13 +258,13 @@ if (APPLE AND BUILD_SHARED_LIBS AND CMAKE_HOST_SYSTEM_VERSION VERSION_LESS 20) "sh -c 'cat ${CMAKE_BINARY_DIR}/CMakeFiles/openblas_shared.dir/objects*.rsp | xargs -n 1024 ${CMAKE_AR} -ru libopenblas.a && exit 0' " "sh -c '${CMAKE_AR} -ru libopenblas.a ${CMAKE_BINARY_DIR}/driver/others/CMakeFiles/driver_others.dir/xerbla.c.o && exit 0' " "sh -c 'echo \"\" | ${CMAKE_Fortran_COMPILER} -o dummy.o -c -x f95-cpp-input - '" - "sh -c '${CMAKE_Fortran_COMPILER} -fpic -shared -Wl,-all_load -Wl,-force_load,libopenblas.a -Wl,-noall_load dummy.o -o ${CMAKE_LIBRARY_OUTPUT_DIRECTORY}/libopenblas.${OpenBLAS_MAJOR_VERSION}.${OpenBLAS_MINOR_VERSION}.dylib'" + "sh -c '${CMAKE_Fortran_COMPILER} -fpic -shared -Wl,-all_load -Wl,-force_load,libopenblas.a -Wl,-noall_load dummy.o -undefined dynamic_lookup -o ${CMAKE_LIBRARY_OUTPUT_DIRECTORY}/libopenblas.${OpenBLAS_MAJOR_VERSION}.${OpenBLAS_MINOR_VERSION}.dylib'" "sh -c 'ls -l ${CMAKE_BINARY_DIR}/lib'") else () set (CMAKE_C_CREATE_SHARED_LIBRARY "sh -c 'cat ${CMAKE_BINARY_DIR}/CMakeFiles/openblas_shared.dir/objects*.rsp | xargs -n 1024 ${CMAKE_AR} -ru libopenblas.a && exit 0' " "sh -c '${CMAKE_AR} -ru libopenblas.a ${CMAKE_BINARY_DIR}/driver/others/CMakeFiles/driver_others.dir/xerbla.c.o && exit 0' " - "sh -c '${CMAKE_C_COMPILER} -fpic -shared -Wl,-all_load -Wl,-force_load,libopenblas.a -Wl,-noall_load -o ${CMAKE_LIBRARY_OUTPUT_DIRECTORY}/libopenblas.${OpenBLAS_MAJOR_VERSION}.${OpenBLAS_MINOR_VERSION}.dylib'") + "sh -c '${CMAKE_C_COMPILER} -fpic -shared -Wl,-all_load -Wl,-force_load,libopenblas.a -Wl,-noall_load -undefined dynamic_lookup -o ${CMAKE_LIBRARY_OUTPUT_DIRECTORY}/libopenblas.${OpenBLAS_MAJOR_VERSION}.${OpenBLAS_MINOR_VERSION}.dylib'") endif () endif() From 08fde5ebd206d4f808069668a4020d64852da34d Mon Sep 17 00:00:00 2001 From: "Kirill A. Korinsky" Date: Thu, 30 Nov 2023 21:24:58 +0000 Subject: [PATCH 34/60] Use 64bit build on `CMAKE_SYSTEM_PROCESSOR=i386` on Darwin Here a bit tricky things. A value `CMAKE_SYSTEM_PROCESSOR` is came from output of `uname -m` which migth be 32bit with 64bit building applicaiton. So, for that case use `CMAKE_SIZEOF_VOID_P` to detect the target. See https://trac.macports.org/ticket/68488 --- cmake/system_check.cmake | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/cmake/system_check.cmake b/cmake/system_check.cmake index 49b9863e3..c9671b379 100644 --- a/cmake/system_check.cmake +++ b/cmake/system_check.cmake @@ -46,7 +46,7 @@ elseif(CMAKE_SYSTEM_PROCESSOR MATCHES "loongarch64.*") set(LOONGARCH64 1) elseif(CMAKE_SYSTEM_PROCESSOR MATCHES "riscv64.*") set(RISCV64 1) -elseif(CMAKE_SYSTEM_PROCESSOR MATCHES "amd64.*|x86_64.*|AMD64.*") +elseif(CMAKE_SYSTEM_PROCESSOR MATCHES "amd64.*|x86_64.*|AMD64.*" OR (CMAKE_SYSTEM_NAME MATCHES "Darwin" AND CMAKE_SYSTEM_PROCESSOR MATCHES "i686.*|i386.*|x86.*")) if (NOT BINARY) if("${CMAKE_SIZEOF_VOID_P}" EQUAL "8") set(X86_64 1) From a53a79e059545e2935e2745f41cf3498277f1a1e Mon Sep 17 00:00:00 2001 From: Martin Kroeker Date: Tue, 5 Dec 2023 15:41:39 +0100 Subject: [PATCH 35/60] Add tests for the DMD functions (Reference-LAPACK PR 736) --- lapack-netlib/TESTING/EIG/Makefile | 58 +- lapack-netlib/TESTING/EIG/cchkdmd.f90 | 721 +++++++++++++++++++++++ lapack-netlib/TESTING/EIG/dchkdmd.f90 | 813 ++++++++++++++++++++++++++ lapack-netlib/TESTING/EIG/schkdmd.f90 | 792 +++++++++++++++++++++++++ lapack-netlib/TESTING/EIG/zchkdmd.f90 | 745 +++++++++++++++++++++++ 5 files changed, 3116 insertions(+), 13 deletions(-) create mode 100644 lapack-netlib/TESTING/EIG/cchkdmd.f90 create mode 100644 lapack-netlib/TESTING/EIG/dchkdmd.f90 create mode 100644 lapack-netlib/TESTING/EIG/schkdmd.f90 create mode 100644 lapack-netlib/TESTING/EIG/zchkdmd.f90 diff --git a/lapack-netlib/TESTING/EIG/Makefile b/lapack-netlib/TESTING/EIG/Makefile index 942ae6982..5de315b6e 100644 --- a/lapack-netlib/TESTING/EIG/Makefile +++ b/lapack-netlib/TESTING/EIG/Makefile @@ -64,6 +64,8 @@ SEIGTST = schkee.o \ sort03.o ssbt21.o ssgt01.o sslect.o sspt21.o sstt21.o \ sstt22.o ssyl01.o ssyt21.o ssyt22.o +SDMDEIGTST = schkdmd.o + CEIGTST = cchkee.o \ cbdt01.o cbdt02.o cbdt03.o cbdt05.o \ cchkbb.o cchkbd.o cchkbk.o cchkbl.o cchkec.o \ @@ -81,6 +83,8 @@ CEIGTST = cchkee.o \ csgt01.o cslect.o csyl01.o\ cstt21.o cstt22.o cunt01.o cunt03.o +CDMDEIGTST = cchkdmd.o + DZIGTST = dlafts.o dlahd2.o dlasum.o dlatb9.o dstech.o dstect.o \ dsvdch.o dsvdct.o dsxt1.o @@ -101,6 +105,8 @@ DEIGTST = dchkee.o \ dort03.o dsbt21.o dsgt01.o dslect.o dspt21.o dstt21.o \ dstt22.o dsyl01.o dsyt21.o dsyt22.o +DDMDEIGTST = dchkdmd.o + ZEIGTST = zchkee.o \ zbdt01.o zbdt02.o zbdt03.o zbdt05.o \ zchkbb.o zchkbd.o zchkbk.o zchkbl.o zchkec.o \ @@ -118,27 +124,45 @@ ZEIGTST = zchkee.o \ zsgt01.o zslect.o zsyl01.o\ zstt21.o zstt22.o zunt01.o zunt03.o +ZDMDEIGTST = zchkdmd.o + .PHONY: all all: single complex double complex16 .PHONY: single complex double complex16 -single: xeigtsts -complex: xeigtstc -double: xeigtstd -complex16: xeigtstz +single: xeigtsts xdmdeigtsts +complex: xeigtstc xdmdeigtstc +double: xeigtstd xdmdeigtstd +complex16: xeigtstz xdmdeigtstz + +xdmdeigtsts: $(SDMDEIGTST) $(TMGLIB) $(LAPACKLIB) $(BLASLIB) + $(FC) $(FFLAGS) $(LDFLAGS) -o $@ $^ + +xdmdeigtstc: $(CDMDEIGTST) $(TMGLIB) $(LAPACKLIB) $(BLASLIB) + $(FC) $(FFLAGS) $(LDFLAGS) -o $@ $^ -xeigtsts: $(SEIGTST) $(SCIGTST) $(AEIGTST) $(TMGLIB) ../$(LAPACKLIB) $(BLASLIB) - $(LOADER) $(FFLAGS) $(LDFLAGS) -o $@ $^ +xdmdeigtstd: $(DDMDEIGTST) $(TMGLIB) $(LAPACKLIB) $(BLASLIB) + $(FC) $(FFLAGS) $(LDFLAGS) -o $@ $^ -xeigtstc: $(CEIGTST) $(SCIGTST) $(AEIGTST) $(TMGLIB) ../$(LAPACKLIB) $(BLASLIB) - $(LOADER) $(FFLAGS) $(LDFLAGS) -o $@ $^ +xdmdeigtstz: $(ZDMDEIGTST) $(TMGLIB) $(LAPACKLIB) $(BLASLIB) + $(FC) $(FFLAGS) $(LDFLAGS) -o $@ $^ -xeigtstd: $(DEIGTST) $(DZIGTST) $(AEIGTST) $(TMGLIB) ../$(LAPACKLIB) $(BLASLIB) - $(LOADER) $(FFLAGS) $(LDFLAGS) -o $@ $^ +xeigtsts: $(SEIGTST) $(SCIGTST) $(AEIGTST) $(TMGLIB) $(LAPACKLIB) $(BLASLIB) + $(FC) $(FFLAGS) $(LDFLAGS) -o $@ $^ -xeigtstz: $(ZEIGTST) $(DZIGTST) $(AEIGTST) $(TMGLIB) ../$(LAPACKLIB) $(BLASLIB) - $(LOADER) $(FFLAGS) $(LDFLAGS) -o $@ $^ +xeigtstc: $(CEIGTST) $(SCIGTST) $(AEIGTST) $(TMGLIB) $(LAPACKLIB) $(BLASLIB) + $(FC) $(FFLAGS) $(LDFLAGS) -o $@ $^ +xeigtstd: $(DEIGTST) $(DZIGTST) $(AEIGTST) $(TMGLIB) $(LAPACKLIB) $(BLASLIB) + $(FC) $(FFLAGS) $(LDFLAGS) -o $@ $^ + +xeigtstz: $(ZEIGTST) $(DZIGTST) $(AEIGTST) $(TMGLIB) $(LAPACKLIB) $(BLASLIB) + $(FC) $(FFLAGS) $(LDFLAGS) -o $@ $^ + +$(SDMDEIGTST): $(FRC) +$(CDMDEIGTST): $(FRC) +$(DDMDEIGTST): $(FRC) +$(ZDMDEIGTST): $(FRC) $(AEIGTST): $(FRC) $(SCIGTST): $(FRC) $(DZIGTST): $(FRC) @@ -155,7 +179,7 @@ clean: cleanobj cleanexe cleanobj: rm -f *.o cleanexe: - rm -f xeigtst* + rm -f xeigtst* xdmdeigtst* schkee.o: schkee.F $(FC) $(FFLAGS_DRV) -c -o $@ $< @@ -165,3 +189,11 @@ cchkee.o: cchkee.F $(FC) $(FFLAGS_DRV) -c -o $@ $< zchkee.o: zchkee.F $(FC) $(FFLAGS_DRV) -c -o $@ $< +schkdmd.o: schkdmd.f90 + $(FC) $(FFLAGS_DRV) -c -o $@ $< +cchkdmd.o: cchkdmd.f90 + $(FC) $(FFLAGS_DRV) -c -o $@ $< +dchkdmd.o: dchkdmd.f90 + $(FC) $(FFLAGS_DRV) -c -o $@ $< +zchkdmd.o: zchkdmd.f90 + $(FC) $(FFLAGS_DRV) -c -o $@ $< diff --git a/lapack-netlib/TESTING/EIG/cchkdmd.f90 b/lapack-netlib/TESTING/EIG/cchkdmd.f90 new file mode 100644 index 000000000..a9c181da9 --- /dev/null +++ b/lapack-netlib/TESTING/EIG/cchkdmd.f90 @@ -0,0 +1,721 @@ +! This is a test program for checking the implementations of +! the implementations of the following subroutines +! +! CGEDMD, for computation of the +! Dynamic Mode Decomposition (DMD) +! CGEDMDQ, for computation of a +! QR factorization based compressed DMD +! +! Developed and supported by: +! =========================== +! Developed and coded by Zlatko Drmac, Faculty of Science, +! University of Zagreb; drmac@math.hr +! In cooperation with +! AIMdyn Inc., Santa Barbara, CA. +! ======================================================== +! How to run the code (compiler, link info) +! ======================================================== +! Compile as FORTRAN 90 (or later) and link with BLAS and +! LAPACK libraries. +! NOTE: The code is developed and tested on top of the +! Intel MKL library (versions 2022.0.3 and 2022.2.0), +! using the Intel Fortran compiler. +! +! For developers of the C++ implementation +! ======================================================== +! See the LAPACK++ and Template Numerical Toolkit (TNT) +! +! Note on a development of the GPU HP implementation +! ======================================================== +! Work in progress. See CUDA, MAGMA, SLATE. +! NOTE: The four SVD subroutines used in this code are +! included as a part of R&D and for the completeness. +! This was also an opportunity to test those SVD codes. +! If the scaling option is used all four are essentially +! equally good. For implementations on HP platforms, +! one can use whichever SVD is available. +!............................................................ + +!............................................................ +!............................................................ +! + PROGRAM DMD_TEST + + use iso_fortran_env + IMPLICIT NONE + integer, parameter :: WP = real32 +!............................................................ + REAL(KIND=WP), PARAMETER :: ONE = 1.0_WP + REAL(KIND=WP), PARAMETER :: ZERO = 0.0_WP + + COMPLEX(KIND=WP), PARAMETER :: CONE = ( 1.0_WP, 0.0_WP ) + COMPLEX(KIND=WP), PARAMETER :: CZERO = ( 0.0_WP, 0.0_WP ) +!............................................................ + REAL(KIND=WP), ALLOCATABLE, DIMENSION(:) :: RES, & + RES1, RESEX, SINGVX, SINGVQX, WORK + INTEGER , ALLOCATABLE, DIMENSION(:) :: IWORK + REAL(KIND=WP) :: WDUMMY(2) + INTEGER :: IDUMMY(4), ISEED(4) + REAL(KIND=WP) :: ANORM, COND, CONDL, CONDR, EPS, & + TOL, TOL2, SVDIFF, TMP, TMP_AU, & + TMP_FQR, TMP_REZ, TMP_REZQ, TMP_XW, & + TMP_EX +!............................................................ + COMPLEX(KIND=WP) :: CMAX + INTEGER :: LCWORK + COMPLEX(KIND=WP), ALLOCATABLE, DIMENSION(:,:) :: A, AC, & + AU, F, F0, F1, S, W, & + X, X0, Y, Y0, Y1, Z, Z1 + COMPLEX(KIND=WP), ALLOCATABLE, DIMENSION(:) :: CDA, CDR, & + CDL, CEIGS, CEIGSA, CWORK + COMPLEX(KIND=WP) :: CDUMMY(22), CDUM2X2(2,2) +!............................................................ + INTEGER :: K, KQ, LDF, LDS, LDA, LDAU, LDW, LDX, LDY, & + LDZ, LIWORK, LWORK, M, N, LLOOP, NRNK + INTEGER :: i, iJOBREF, iJOBZ, iSCALE, INFO, j, & + NFAIL, NFAIL_AU, NFAIL_F_QR, NFAIL_REZ, & + NFAIL_REZQ, NFAIL_SVDIFF, NFAIL_TOTAL, NFAILQ_TOTAL, & + NFAIL_Z_XV, MODE, MODEL, MODER, WHTSVD + INTEGER :: iNRNK, iWHTSVD, K_traj, LWMINOPT + CHARACTER :: GRADE, JOBREF, JOBZ, PIVTNG, RSIGN, & + SCALE, RESIDS, WANTQ, WANTR + LOGICAL :: TEST_QRDMD + +!..... external subroutines (BLAS and LAPACK) + EXTERNAL CAXPY, CGEEV, CGEMM, CGEMV, CLASCL +!.....external subroutines DMD package +! subroutines under test + EXTERNAL CGEDMD, CGEDMDQ +!..... external functions (BLAS and LAPACK) + EXTERNAL SCNRM2, SLAMCH + REAL(KIND=WP) :: SCNRM2, SLAMCH + EXTERNAL CLANGE + REAL(KIND=WP) :: CLANGE + EXTERNAL ICAMAX + INTEGER ICAMAX + EXTERNAL LSAME + LOGICAL LSAME + + INTRINSIC ABS, INT, MIN, MAX, SIGN +!............................................................ + + + WRITE(*,*) 'COMPLEX CODE TESTING' + + ! The test is always in pairs : ( CGEDMD and CGEDMDQ) + ! because the test includes comparing the results (in pairs). +!..................................................................................... + ! This code by default performs tests on CGEDMDQ + ! Since the QR factorizations based algorithm is designed for + ! single trajectory data, only single trajectory tests will + ! be performed with xGEDMDQ. + + WANTQ = 'Q' + WANTR = 'R' +!................................................................................. + + EPS = SLAMCH( 'P' ) ! machine precision WP + + ! Global counters of failures of some particular tests + NFAIL = 0 + NFAIL_REZ = 0 + NFAIL_REZQ = 0 + NFAIL_Z_XV = 0 + NFAIL_F_QR = 0 + NFAIL_AU = 0 + NFAIL_SVDIFF = 0 + NFAIL_TOTAL = 0 + NFAILQ_TOTAL = 0 + + DO LLOOP = 1, 4 + + WRITE(*,*) 'L Loop Index = ', LLOOP + + ! Set the dimensions of the problem ... + READ(*,*) M + WRITE(*,*) 'M = ', M + ! ... and the number of snapshots. + READ(*,*) N + WRITE(*,*) 'N = ', N + + ! Test the dimensions + IF ( ( MIN(M,N) == 0 ) .OR. ( M < N ) ) THEN + WRITE(*,*) 'Bad dimensions. Required: M >= N > 0.' + STOP + END IF +!............. + ! The seed inside the LLOOP so that each pass can be reproduced easily. + ISEED(1) = 4 + ISEED(2) = 3 + ISEED(3) = 2 + ISEED(4) = 1 + + LDA = M + LDF = M + LDX = M + LDY = M + LDW = N + LDZ = M + LDAU = M + LDS = N + + TMP_XW = ZERO + TMP_AU = ZERO + TMP_REZ = ZERO + TMP_REZQ = ZERO + SVDIFF = ZERO + TMP_EX = ZERO + + ALLOCATE( A(LDA,M) ) + ALLOCATE( AC(LDA,M) ) + ALLOCATE( F(LDF,N+1) ) + ALLOCATE( F0(LDF,N+1) ) + ALLOCATE( F1(LDF,N+1) ) + ALLOCATE( X(LDX,N) ) + ALLOCATE( X0(LDX,N) ) + ALLOCATE( Y(LDY,N+1) ) + ALLOCATE( Y0(LDY,N+1) ) + ALLOCATE( Y1(LDY,N+1) ) + ALLOCATE( AU(LDAU,N) ) + ALLOCATE( W(LDW,N) ) + ALLOCATE( S(LDS,N) ) + ALLOCATE( Z(LDZ,N) ) + ALLOCATE( Z1(LDZ,N) ) + ALLOCATE( RES(N) ) + ALLOCATE( RES1(N) ) + ALLOCATE( RESEX(N) ) + ALLOCATE( CEIGS(N) ) + ALLOCATE( SINGVX(N) ) + ALLOCATE( SINGVQX(N) ) + + TOL = 10*M*EPS + TOL2 = 10*M*N*EPS + +!............. + + DO K_traj = 1, 2 + ! Number of intial conditions in the simulation/trajectories (1 or 2) + + COND = 1.0D4 + CMAX = (1.0D1,1.0D1) + RSIGN = 'F' + GRADE = 'N' + MODEL = 6 + CONDL = 1.0D1 + MODER = 6 + CONDR = 1.0D1 + PIVTNG = 'N' + ! Loop over all parameter MODE values for CLATMR (+-1,..,+-6) + + DO MODE = 1, 6 + + ALLOCATE( IWORK(2*M) ) + ALLOCATE( CDA(M) ) + ALLOCATE( CDL(M) ) + ALLOCATE( CDR(M) ) + + CALL CLATMR( M, M, 'N', ISEED, 'N', CDA, MODE, COND, & + CMAX, RSIGN, GRADE, CDL, MODEL, CONDL, & + CDR, MODER, CONDR, PIVTNG, IWORK, M, M, & + ZERO, -ONE, 'N', A, LDA, IWORK(M+1), INFO ) + DEALLOCATE( CDR ) + DEALLOCATE( CDL ) + DEALLOCATE( CDA ) + DEALLOCATE( IWORK ) + + LCWORK = MAX(1,2*M) + ALLOCATE( CEIGSA(M) ) + ALLOCATE( CWORK(LCWORK) ) + ALLOCATE( WORK(2*M) ) + AC(1:M,1:M) = A(1:M,1:M) + CALL CGEEV( 'N','N', M, AC, LDA, CEIGSA, CDUM2X2, 2, & + CDUM2X2, 2, CWORK, LCWORK, WORK, INFO ) ! LAPACK CALL + DEALLOCATE(WORK) + DEALLOCATE(CWORK) + + TMP = ABS(CEIGSA(ICAMAX(M, CEIGSA, 1))) ! The spectral radius of A + ! Scale the matrix A to have unit spectral radius. + CALL CLASCL( 'G',0, 0, TMP, ONE, M, M, & + A, LDA, INFO ) + CALL CLASCL( 'G',0, 0, TMP, ONE, M, 1, & + CEIGSA, M, INFO ) + ANORM = CLANGE( 'F', M, M, A, LDA, WDUMMY ) + + IF ( K_traj == 2 ) THEN + ! generate data as two trajectories + ! with two inital conditions + CALL CLARNV(2, ISEED, M, F(1,1) ) + DO i = 1, N/2 + CALL CGEMV( 'N', M, M, CONE, A, LDA, F(1,i), 1, & + CZERO, F(1,i+1), 1 ) + END DO + X0(1:M,1:N/2) = F(1:M,1:N/2) + Y0(1:M,1:N/2) = F(1:M,2:N/2+1) + + CALL CLARNV(2, ISEED, M, F(1,1) ) + DO i = 1, N-N/2 + CALL CGEMV( 'N', M, M, CONE, A, LDA, F(1,i), 1, & + CZERO, F(1,i+1), 1 ) + END DO + X0(1:M,N/2+1:N) = F(1:M,1:N-N/2) + Y0(1:M,N/2+1:N) = F(1:M,2:N-N/2+1) + ELSE + CALL CLARNV(2, ISEED, M, F(1,1) ) + DO i = 1, N + CALL CGEMV( 'N', M, M, CONE, A, M, F(1,i), 1, & + CZERO, F(1,i+1), 1 ) + END DO + F0(1:M,1:N+1) = F(1:M,1:N+1) + X0(1:M,1:N) = F0(1:M,1:N) + Y0(1:M,1:N) = F0(1:M,2:N+1) + END IF + + DEALLOCATE( CEIGSA ) +!........................................................................ + + DO iJOBZ = 1, 4 + + SELECT CASE ( iJOBZ ) + CASE(1) + JOBZ = 'V' + RESIDS = 'R' + CASE(2) + JOBZ = 'V' + RESIDS = 'N' + CASE(3) + JOBZ = 'F' + RESIDS = 'N' + CASE(4) + JOBZ = 'N' + RESIDS = 'N' + END SELECT + + DO iJOBREF = 1, 3 + + SELECT CASE ( iJOBREF ) + CASE(1) + JOBREF = 'R' + CASE(2) + JOBREF = 'E' + CASE(3) + JOBREF = 'N' + END SELECT + + DO iSCALE = 1, 4 + + SELECT CASE ( iSCALE ) + CASE(1) + SCALE = 'S' + CASE(2) + SCALE = 'C' + CASE(3) + SCALE = 'Y' + CASE(4) + SCALE = 'N' + END SELECT + + DO iNRNK = -1, -2, -1 + NRNK = iNRNK + + DO iWHTSVD = 1, 3 + ! Check all four options to compute the POD basis + ! via the SVD. + WHTSVD = iWHTSVD + + DO LWMINOPT = 1, 2 + ! Workspace query for the minimal (1) and for the optimal + ! (2) workspace lengths determined by workspace query. + + ! CGEDMD is always tested and its results are also used for + ! comparisons with CGEDMDQ. + + X(1:M,1:N) = X0(1:M,1:N) + Y(1:M,1:N) = Y0(1:M,1:N) + + CALL CGEDMD( SCALE, JOBZ, RESIDS, JOBREF, WHTSVD, & + M, N, X, LDX, Y, LDY, NRNK, TOL, & + K, CEIGS, Z, LDZ, RES, & + AU, LDAU, W, LDW, S, LDS, & + CDUMMY, -1, WDUMMY, -1, IDUMMY, -1, INFO ) + + IF ( (INFO .EQ. 2) .OR. ( INFO .EQ. 3 ) & + .OR. ( INFO < 0 ) ) THEN + WRITE(*,*) 'Call to CGEDMD workspace query failed. & + &Check the calling sequence and the code.' + WRITE(*,*) 'The error code is ', INFO + WRITE(*,*) 'The input parameters were ', & + SCALE, JOBZ, RESIDS, JOBREF, WHTSVD, & + M, N, LDX, LDY, NRNK, TOL, LDZ, LDAU, LDW, LDS + STOP + ELSE + !WRITE(*,*) '... done. Workspace length computed.' + END IF + + LCWORK = INT(CDUMMY(LWMINOPT)) + ALLOCATE(CWORK(LCWORK)) + LIWORK = IDUMMY(1) + ALLOCATE(IWORK(LIWORK)) + LWORK = INT(WDUMMY(1)) + ALLOCATE(WORK(LWORK)) + + CALL CGEDMD( SCALE, JOBZ, RESIDS, JOBREF, WHTSVD, & + M, N, X, LDX, Y, LDY, NRNK, TOL, & + K, CEIGS, Z, LDZ, RES, & + AU, LDAU, W, LDW, S, LDS, & + CWORK, LCWORK, WORK, LWORK, IWORK, LIWORK, INFO ) + IF ( INFO /= 0 ) THEN + WRITE(*,*) 'Call to CGEDMD failed. & + &Check the calling sequence and the code.' + WRITE(*,*) 'The error code is ', INFO + WRITE(*,*) 'The input parameters were ',& + SCALE, JOBZ, RESIDS, JOBREF, WHTSVD, & + M, N, LDX, LDY, NRNK, TOL + STOP + END IF + SINGVX(1:N) = WORK(1:N) + + !...... CGEDMD check point + IF ( LSAME(JOBZ,'V') ) THEN + ! Check that Z = X*W, on return from CGEDMD + ! This checks that the returned eigenvectors in Z are + ! the product of the SVD'POD basis returned in X + ! and the eigenvectors of the Rayleigh quotient + ! returned in W + CALL CGEMM( 'N', 'N', M, K, K, CONE, X, LDX, W, LDW, & + CZERO, Z1, LDZ ) + TMP = ZERO + DO i = 1, K + CALL CAXPY( M, -CONE, Z(1,i), 1, Z1(1,i), 1) + TMP = MAX(TMP, SCNRM2( M, Z1(1,i), 1 ) ) + END DO + TMP_XW = MAX(TMP_XW, TMP ) + IF ( TMP_XW <= TOL ) THEN + !WRITE(*,*) ' :) .... OK .........CGEDMD PASSED.' + ELSE + NFAIL_Z_XV = NFAIL_Z_XV + 1 + WRITE(*,*) ':( .................CGEDMD FAILED!', & + 'Check the code for implementation errors.' + WRITE(*,*) 'The input parameters were ',& + SCALE, JOBZ, RESIDS, JOBREF, WHTSVD, & + M, N, LDX, LDY, NRNK, TOL + END IF + END IF + !...... CGEDMD check point + + IF ( LSAME(JOBREF,'R') ) THEN + ! The matrix A*U is returned for computing refined Ritz vectors. + ! Check that A*U is computed correctly using the formula + ! A*U = Y * V * inv(SIGMA). This depends on the + ! accuracy in the computed singular values and vectors of X. + ! See the paper for an error analysis. + ! Note that the left singular vectors of the input matrix X + ! are returned in the array X. + CALL CGEMM( 'N', 'N', M, K, M, CONE, A, LDA, X, LDX, & + CZERO, Z1, LDZ ) + TMP = ZERO + DO i = 1, K + CALL CAXPY( M, -CONE, AU(1,i), 1, Z1(1,i), 1) + TMP = MAX( TMP, SCNRM2( M, Z1(1,i),1 ) * & + SINGVX(K)/(ANORM*SINGVX(1)) ) + END DO + TMP_AU = MAX( TMP_AU, TMP ) + IF ( TMP <= TOL2 ) THEN + !WRITE(*,*) ':) .... OK .........CGEDMD PASSED.' + ELSE + NFAIL_AU = NFAIL_AU + 1 + WRITE(*,*) ':( .................CGEDMD FAILED!', & + 'Check the code for implementation errors.' + WRITE(*,*) 'The input parameters were ',& + SCALE, JOBZ, RESIDS, JOBREF, WHTSVD, & + M, N, LDX, LDY, NRNK, TOL2 + END IF + ELSEIF ( LSAME(JOBREF,'E') ) THEN + ! The unscaled vectors of the Exact DMD are computed. + ! This option is included for the sake of completeness, + ! for users who prefer the Exact DMD vectors. The + ! returned vectors are in the real form, in the same way + ! as the Ritz vectors. Here we just save the vectors + ! and test them separately using a Matlab script. + CALL CGEMM( 'N', 'N', M, K, M, CONE, A, LDA, AU, LDAU, CZERO, Y1, LDY ) + + DO i=1, K + CALL CAXPY( M, -CEIGS(i), AU(1,i), 1, Y1(1,i), 1 ) + RESEX(i) = SCNRM2( M, Y1(1,i), 1) / SCNRM2(M,AU(1,i),1) + END DO + END IF + !...... CGEDMD check point + + IF ( LSAME(RESIDS, 'R') ) THEN + ! Compare the residuals returned by CGEDMD with the + ! explicitly computed residuals using the matrix A. + ! Compute explicitly Y1 = A*Z + CALL CGEMM( 'N', 'N', M, K, M, CONE, A, LDA, Z, LDZ, CZERO, Y1, LDY ) + ! ... and then A*Z(:,i) - LAMBDA(i)*Z(:,i), using the real forms + ! of the invariant subspaces that correspond to complex conjugate + ! pairs of eigencalues. (See the description of Z in CGEDMD,) + + DO i=1, K + ! have a real eigenvalue with real eigenvector + CALL CAXPY( M, -CEIGS(i), Z(1,i), 1, Y1(1,i), 1 ) + RES1(i) = SCNRM2( M, Y1(1,i), 1) + END DO + TMP = ZERO + DO i = 1, K + TMP = MAX( TMP, ABS(RES(i) - RES1(i)) * & + SINGVX(K)/(ANORM*SINGVX(1)) ) + END DO + TMP_REZ = MAX( TMP_REZ, TMP ) + IF ( TMP <= TOL2 ) THEN + !WRITE(*,*) ':) .... OK ..........CGEDMD PASSED.' + ELSE + NFAIL_REZ = NFAIL_REZ + 1 + WRITE(*,*) ':( ..................CGEDMD FAILED!', & + 'Check the code for implementation errors.' + WRITE(*,*) 'The input parameters were ',& + SCALE, JOBZ, RESIDS, JOBREF, WHTSVD, & + M, N, LDX, LDY, NRNK, TOL + END IF + + + IF ( LSAME(JOBREF,'E') ) THEN + TMP = ZERO + DO i = 1, K + TMP = MAX( TMP, ABS(RES1(i) - RESEX(i))/(RES1(i)+RESEX(i)) ) + END DO + TMP_EX = MAX(TMP_EX,TMP) + END IF + + END IF + + DEALLOCATE(CWORK) + DEALLOCATE(WORK) + DEALLOCATE(IWORK) + +!....................................................................................................... + + IF ( K_traj == 1 ) THEN + + F(1:M,1:N+1) = F0(1:M,1:N+1) + CALL CGEDMDQ( SCALE, JOBZ, RESIDS, WANTQ, WANTR, JOBREF, & + WHTSVD, M, N+1, F, LDF, X, LDX, Y, LDY, & + NRNK, TOL, K, CEIGS, Z, LDZ, RES, AU, & + LDAU, W, LDW, S, LDS, CDUMMY, -1, & + WDUMMY, -1, IDUMMY, -1, INFO ) + + LCWORK = INT(CDUMMY(LWMINOPT)) + ALLOCATE(CWORK(LCWORK)) + LIWORK = IDUMMY(1) + ALLOCATE(IWORK(LIWORK)) + LWORK = INT(WDUMMY(1)) + ALLOCATE(WORK(LWORK)) + + CALL CGEDMDQ( SCALE, JOBZ, RESIDS, WANTQ, WANTR, JOBREF, & + WHTSVD, M, N+1, F, LDF, X, LDX, Y, LDY, & + NRNK, TOL, KQ, CEIGS, Z, LDZ, RES, AU, & + LDAU, W, LDW, S, LDS, CWORK, LCWORK, & + WORK, LWORK, IWORK, LIWORK, INFO ) + IF ( INFO /= 0 ) THEN + WRITE(*,*) 'Call to CGEDMDQ failed. & + &Check the calling sequence and the code.' + WRITE(*,*) 'The error code is ', INFO + WRITE(*,*) 'The input parameters were ',& + SCALE, JOBZ, RESIDS, WANTQ, WANTR, WHTSVD, & + M, N, LDX, LDY, NRNK, TOL + STOP + END IF + SINGVQX(1:N) =WORK(1:N) + + !..... ZGEDMDQ check point + + TMP = ZERO + DO i = 1, MIN(K, KQ) + TMP = MAX(TMP, ABS(SINGVX(i)-SINGVQX(i)) / & + SINGVX(1) ) + END DO + SVDIFF = MAX( SVDIFF, TMP ) + IF ( TMP > TOL2 ) THEN + WRITE(*,*) 'FAILED! Something was wrong with the run.' + NFAIL_SVDIFF = NFAIL_SVDIFF + 1 + END IF + !..... CGEDMDQ check point + + !..... CGEDMDQ check point + IF ( LSAME(WANTQ,'Q') .AND. LSAME(WANTR,'R') ) THEN + ! Check that the QR factors are computed and returned + ! as requested. The residual ||F-Q*R||_F / ||F||_F + ! is compared to M*N*EPS. + F1(1:M,1:N+1) = F0(1:M,1:N+1) + CALL CGEMM( 'N', 'N', M, N+1, MIN(M,N+1), -CONE, F, & + LDF, Y, LDY, CONE, F1, LDF ) + TMP_FQR = CLANGE( 'F', M, N+1, F1, LDF, WORK ) / & + CLANGE( 'F', M, N+1, F0, LDF, WORK ) + IF ( TMP_FQR <= TOL2 ) THEN + !WRITE(*,*) ':) CGEDMDQ ........ PASSED.' + ELSE + WRITE(*,*) ':( CGEDMDQ ........ FAILED.' + NFAIL_F_QR = NFAIL_F_QR + 1 + END IF + END IF + !..... ZGEDMDQ checkpoint + !..... ZGEDMDQ checkpoint + IF ( LSAME(RESIDS, 'R') ) THEN + ! Compare the residuals returned by ZGEDMDQ with the + ! explicitly computed residuals using the matrix A. + ! Compute explicitly Y1 = A*Z + CALL CGEMM( 'N', 'N', M, KQ, M, CONE, A, LDA, Z, LDZ, CZERO, Y1, LDY ) + ! ... and then A*Z(:,i) - LAMBDA(i)*Z(:,i), using the real forms + ! of the invariant subspaces that correspond to complex conjugate + ! pairs of eigencalues. (See the description of Z in ZGEDMDQ) + DO i = 1, KQ + ! have a real eigenvalue with real eigenvector + CALL CAXPY( M, -CEIGS(i), Z(1,i), 1, Y1(1,i), 1 ) + ! Y(1:M,i) = Y(1:M,i) - REIG(i)*Z(1:M,i) + RES1(i) = SCNRM2( M, Y1(1,i), 1) + END DO + TMP = ZERO + DO i = 1, KQ + TMP = MAX( TMP, ABS(RES(i) - RES1(i)) * & + SINGVQX(KQ)/(ANORM*SINGVQX(1)) ) + END DO + TMP_REZQ = MAX( TMP_REZQ, TMP ) + IF ( TMP <= TOL2 ) THEN + !WRITE(*,*) '.... OK ........ CGEDMDQ PASSED.' + ELSE + NFAIL_REZQ = NFAIL_REZQ + 1 + WRITE(*,*) '................ CGEDMDQ FAILED!', & + 'Check the code for implementation errors.' + END IF + END IF + + DEALLOCATE(CWORK) + DEALLOCATE(WORK) + DEALLOCATE(IWORK) + + END IF + + END DO ! LWMINOPT + !write(*,*) 'LWMINOPT loop completed' + END DO ! iWHTSVD + !write(*,*) 'WHTSVD loop completed' + END DO ! iNRNK -2:-1 + !write(*,*) 'NRNK loop completed' + END DO ! iSCALE 1:4 + !write(*,*) 'SCALE loop completed' + END DO + !write(*,*) 'JOBREF loop completed' + END DO ! iJOBZ + !write(*,*) 'JOBZ loop completed' + + END DO ! MODE -6:6 + !write(*,*) 'MODE loop completed' + END DO ! 1 or 2 trajectories + !write(*,*) 'trajectories loop completed' + + DEALLOCATE( A ) + DEALLOCATE( AC ) + DEALLOCATE( Z ) + DEALLOCATE( F ) + DEALLOCATE( F0 ) + DEALLOCATE( F1 ) + DEALLOCATE( X ) + DEALLOCATE( X0 ) + DEALLOCATE( Y ) + DEALLOCATE( Y0 ) + DEALLOCATE( Y1 ) + DEALLOCATE( AU ) + DEALLOCATE( W ) + DEALLOCATE( S ) + DEALLOCATE( Z1 ) + DEALLOCATE( RES ) + DEALLOCATE( RES1 ) + DEALLOCATE( RESEX ) + DEALLOCATE( CEIGS ) + DEALLOCATE( SINGVX ) + DEALLOCATE( SINGVQX ) + + END DO ! LLOOP + + WRITE(*,*) + WRITE(*,*) '>>>>>>>>>>>>>>>>>>>>>>>>>>' + WRITE(*,*) ' Test summary for CGEDMD :' + WRITE(*,*) '>>>>>>>>>>>>>>>>>>>>>>>>>>' + WRITE(*,*) + IF ( NFAIL_Z_XV == 0 ) THEN + WRITE(*,*) '>>>> Z - U*V test PASSED.' + ELSE + WRITE(*,*) 'Z - U*V test FAILED ', NFAIL_Z_XV, ' time(s)' + WRITE(*,*) 'Max error ||Z-U*V||_F was ', TMP_XW + NFAIL_TOTAL = NFAIL_TOTAL + NFAIL_z_XV + END IF + + IF ( NFAIL_AU == 0 ) THEN + WRITE(*,*) '>>>> A*U test PASSED. ' + ELSE + WRITE(*,*) 'A*U test FAILED ', NFAIL_AU, ' time(s)' + WRITE(*,*) 'Max A*U test adjusted error measure was ', TMP_AU + WRITE(*,*) 'It should be up to O(M*N) times EPS, EPS = ', EPS + NFAIL_TOTAL = NFAIL_TOTAL + NFAIL_AU + END IF + + + IF ( NFAIL_REZ == 0 ) THEN + WRITE(*,*) '>>>> Rezidual computation test PASSED.' + ELSE + WRITE(*,*) 'Rezidual computation test FAILED ', NFAIL_REZ, 'time(s)' + WRITE(*,*) 'Max residual computing test adjusted error measure was ', TMP_REZ + WRITE(*,*) 'It should be up to O(M*N) times EPS, EPS = ', EPS + NFAIL_TOTAL = NFAIL_TOTAL + NFAIL_REZ + END IF + IF ( NFAIL_TOTAL == 0 ) THEN + WRITE(*,*) '>>>> CGEDMD :: ALL TESTS PASSED.' + ELSE + WRITE(*,*) NFAIL_TOTAL, 'FAILURES!' + WRITE(*,*) '>>>>>>>>>>>>>> CGEDMD :: TESTS FAILED. CHECK THE IMPLEMENTATION.' + END IF + + WRITE(*,*) + WRITE(*,*) '>>>>>>>>>>>>>>>>>>>>>>>>>>' + WRITE(*,*) ' Test summary for CGEDMDQ :' + WRITE(*,*) '>>>>>>>>>>>>>>>>>>>>>>>>>>' + WRITE(*,*) + + IF ( NFAIL_SVDIFF == 0 ) THEN + WRITE(*,*) '>>>> CGEDMD and CGEDMDQ computed singular & + &values test PASSED.' + ELSE + WRITE(*,*) 'ZGEDMD and ZGEDMDQ discrepancies in & + &the singular values unacceptable ', & + NFAIL_SVDIFF, ' times. Test FAILED.' + WRITE(*,*) 'The maximal discrepancy in the singular values (relative to the norm) was ', SVDIFF + WRITE(*,*) 'It should be up to O(M*N) times EPS, EPS = ', EPS + NFAILQ_TOTAL = NFAILQ_TOTAL + NFAIL_SVDIFF + END IF + IF ( NFAIL_F_QR == 0 ) THEN + WRITE(*,*) '>>>> F - Q*R test PASSED.' + ELSE + WRITE(*,*) 'F - Q*R test FAILED ', NFAIL_F_QR, ' time(s)' + WRITE(*,*) 'The largest relative residual was ', TMP_FQR + WRITE(*,*) 'It should be up to O(M*N) times EPS, EPS = ', EPS + NFAILQ_TOTAL = NFAILQ_TOTAL + NFAIL_F_QR + END IF + + IF ( NFAIL_REZQ == 0 ) THEN + WRITE(*,*) '>>>> Rezidual computation test PASSED.' + ELSE + WRITE(*,*) 'Rezidual computation test FAILED ', NFAIL_REZQ, 'time(s)' + WRITE(*,*) 'Max residual computing test adjusted error measure was ', TMP_REZQ + WRITE(*,*) 'It should be up to O(M*N) times EPS, EPS = ', EPS + NFAILQ_TOTAL = NFAILQ_TOTAL + NFAIL_REZQ + END IF + + IF ( NFAILQ_TOTAL == 0 ) THEN + WRITE(*,*) '>>>>>>> CGEDMDQ :: ALL TESTS PASSED.' + ELSE + WRITE(*,*) NFAILQ_TOTAL, 'FAILURES!' + WRITE(*,*) '>>>>>>> CGEDMDQ :: TESTS FAILED. CHECK THE IMPLEMENTATION.' + END IF + + WRITE(*,*) + WRITE(*,*) 'Test completed.' + STOP + END diff --git a/lapack-netlib/TESTING/EIG/dchkdmd.f90 b/lapack-netlib/TESTING/EIG/dchkdmd.f90 new file mode 100644 index 000000000..4fbf7531b --- /dev/null +++ b/lapack-netlib/TESTING/EIG/dchkdmd.f90 @@ -0,0 +1,813 @@ +! This is a test program for checking the implementations of +! the implementations of the following subroutines +! +! DGEDMD for computation of the +! Dynamic Mode Decomposition (DMD) +! DGEDMDQ for computation of a +! QR factorization based compressed DMD +! +! Developed and supported by: +! =========================== +! Developed and coded by Zlatko Drmac, Faculty of Science, +! University of Zagreb; drmac@math.hr +! In cooperation with +! AIMdyn Inc., Santa Barbara, CA. +! ======================================================== +! How to run the code (compiler, link info) +! ======================================================== +! Compile as FORTRAN 90 (or later) and link with BLAS and +! LAPACK libraries. +! NOTE: The code is developed and tested on top of the +! Intel MKL library (versions 2022.0.3 and 2022.2.0), +! using the Intel Fortran compiler. +! +! For developers of the C++ implementation +! ======================================================== +! See the LAPACK++ and Template Numerical Toolkit (TNT) +! +! Note on a development of the GPU HP implementation +! ======================================================== +! Work in progress. See CUDA, MAGMA, SLATE. +! NOTE: The four SVD subroutines used in this code are +! included as a part of R&D and for the completeness. +! This was also an opportunity to test those SVD codes. +! If the scaling option is used all four are essentially +! equally good. For implementations on HP platforms, +! one can use whichever SVD is available. +!... ......................................................... +! NOTE: +! When using the Intel MKL 2022.0.3 the subroutine xGESVDQ +! (optionally used in xGEDMD) may cause access violation +! error for x = S, D, C, Z, but only if called with the +! work space query. (At least in our Windows 10 MSVS 2019.) +! The problem can be mitigated by downloading the source +! code of xGESVDQ from the LAPACK repository and use it +! localy instead of the one in the MKL. This seems to +! indicate that the problem is indeed in the MKL. +! This problem did not appear whith Intel MKL 2022.2.0. +! +! NOTE: +! xGESDD seems to have a problem with workspace. In some +! cases the length of the optimal workspace is returned +! smaller than the minimal workspace, as specified in the +! code. As a precaution, all optimal workspaces are +! set as MAX(minimal, optimal). +! Latest implementations of complex xGESDD have different +! length of the real worksapce. We use max value over +! two versions. +!............................................................ +!............................................................ +! + PROGRAM DMD_TEST + use iso_fortran_env, only: real64 + IMPLICIT NONE + integer, parameter :: WP = real64 + +!............................................................ + REAL(KIND=WP), PARAMETER :: ONE = 1.0_WP + REAL(KIND=WP), PARAMETER :: ZERO = 0.0_WP +!............................................................ + REAL(KIND=WP), ALLOCATABLE, DIMENSION(:,:) :: & + A, AC, EIGA, LAMBDA, LAMBDAQ, F, F1, F2,& + Z, Z1, S, AU, W, VA, X, X0, Y, Y0, Y1 + REAL(KIND=WP), ALLOCATABLE, DIMENSION(:) :: & + DA, DL, DR, REIG, REIGA, REIGQ, IEIG, & + IEIGA, IEIGQ, RES, RES1, RESEX, SINGVX,& + SINGVQX, WORK + INTEGER , ALLOCATABLE, DIMENSION(:) :: IWORK + REAL(KIND=WP) :: AB(2,2), WDUMMY(2) + INTEGER :: IDUMMY(2), ISEED(4), RJOBDATA(8) + REAL(KIND=WP) :: ANORM, COND, CONDL, CONDR, DMAX, EPS, & + TOL, TOL2, SVDIFF, TMP, TMP_AU, & + TMP_FQR, TMP_REZ, TMP_REZQ, TMP_ZXW, & + TMP_EX, XNORM, YNORM +!............................................................ + INTEGER :: K, KQ, LDF, LDS, LDA, LDAU, LDW, LDX, LDY, & + LDZ, LIWORK, LWORK, M, N, L, LLOOP, NRNK + INTEGER :: i, iJOBREF, iJOBZ, iSCALE, INFO, j, KDIFF, & + NFAIL, NFAIL_AU, NFAIL_F_QR, NFAIL_REZ, & + NFAIL_REZQ, NFAIL_SVDIFF, NFAIL_TOTAL, NFAILQ_TOTAL, & + NFAIL_Z_XV, MODE, MODEL, MODER, WHTSVD + INTEGER iNRNK, iWHTSVD, K_TRAJ, LWMINOPT + CHARACTER(LEN=1) GRADE, JOBREF, JOBZ, PIVTNG, RSIGN, & + SCALE, RESIDS, WANTQ, WANTR + + LOGICAL TEST_QRDMD +!..... external subroutines (BLAS and LAPACK) + EXTERNAL DAXPY, DGEEV, DGEMM, DGEMV, DLACPY, DLASCL + EXTERNAL DLARNV, DLATMR +!.....external subroutines DMD package, part 1 +! subroutines under test + EXTERNAL DGEDMD, DGEDMDQ + +!..... external functions (BLAS and LAPACK) + EXTERNAL DLAMCH, DLANGE, DNRM2 + REAL(KIND=WP) :: DLAMCH, DLANGE, DNRM2 + EXTERNAL LSAME + LOGICAL LSAME + + INTRINSIC ABS, INT, MIN, MAX +!............................................................ + + ! The test is always in pairs : ( DGEDMD and DGEDMDQ ) + ! because the test includes comparing the results (in pairs). +!..................................................................................... + TEST_QRDMD = .TRUE. ! This code by default performs tests on DGEDMDQ + ! Since the QR factorizations based algorithm is designed for + ! single trajectory data, only single trajectory tests will + ! be performed with xGEDMDQ. + WANTQ = 'Q' + WANTR = 'R' +!................................................................................. + + EPS = DLAMCH( 'P' ) ! machine precision DP + + ! Global counters of failures of some particular tests + NFAIL = 0 + NFAIL_REZ = 0 + NFAIL_REZQ = 0 + NFAIL_Z_XV = 0 + NFAIL_F_QR = 0 + NFAIL_AU = 0 + KDIFF = 0 + NFAIL_SVDIFF = 0 + NFAIL_TOTAL = 0 + NFAILQ_TOTAL = 0 + + + DO LLOOP = 1, 4 + + WRITE(*,*) 'L Loop Index = ', LLOOP + + ! Set the dimensions of the problem ... + WRITE(*,*) 'M = ' + READ(*,*) M + WRITE(*,*) M + ! ... and the number of snapshots. + WRITE(*,*) 'N = ' + READ(*,*) N + WRITE(*,*) N + + ! ... Test the dimensions + IF ( ( MIN(M,N) == 0 ) .OR. ( M < N ) ) THEN + WRITE(*,*) 'Bad dimensions. Required: M >= N > 0.' + STOP + END IF +!............. + ! The seed inside the LLOOP so that each pass can be reproduced easily. + + ISEED(1) = 4 + ISEED(2) = 3 + ISEED(3) = 2 + ISEED(4) = 1 + + LDA = M + LDF = M + LDX = MAX(M,N+1) + LDY = MAX(M,N+1) + LDW = N + LDZ = M + LDAU = MAX(M,N+1) + LDS = N + + TMP_ZXW = ZERO + TMP_AU = ZERO + TMP_REZ = ZERO + TMP_REZQ = ZERO + SVDIFF = ZERO + TMP_EX = ZERO + + ! + ! Test the subroutines on real data snapshots. All + ! computation is done in real arithmetic, even when + ! Koopman eigenvalues and modes are real. + ! + ! Allocate memory space + ALLOCATE( A(LDA,M) ) + ALLOCATE( AC(LDA,M) ) + ALLOCATE( DA(M) ) + ALLOCATE( DL(M) ) + ALLOCATE( F(LDF,N+1) ) + ALLOCATE( F1(LDF,N+1) ) + ALLOCATE( F2(LDF,N+1) ) + ALLOCATE( X(LDX,N) ) + ALLOCATE( X0(LDX,N) ) + ALLOCATE( SINGVX(N) ) + ALLOCATE( SINGVQX(N) ) + ALLOCATE( Y(LDY,N+1) ) + ALLOCATE( Y0(LDY,N+1) ) + ALLOCATE( Y1(M,N+1) ) + ALLOCATE( Z(LDZ,N) ) + ALLOCATE( Z1(LDZ,N) ) + ALLOCATE( RES(N) ) + ALLOCATE( RES1(N) ) + ALLOCATE( RESEX(N) ) + ALLOCATE( REIG(N) ) + ALLOCATE( IEIG(N) ) + ALLOCATE( REIGQ(N) ) + ALLOCATE( IEIGQ(N) ) + ALLOCATE( REIGA(M) ) + ALLOCATE( IEIGA(M) ) + ALLOCATE( VA(LDA,M) ) + ALLOCATE( LAMBDA(N,2) ) + ALLOCATE( LAMBDAQ(N,2) ) + ALLOCATE( EIGA(M,2) ) + ALLOCATE( W(LDW,N) ) + ALLOCATE( AU(LDAU,N) ) + ALLOCATE( S(N,N) ) + + TOL = M*EPS + ! This mimics O(M*N)*EPS bound for accumulated roundoff error. + ! The factor 10 is somewhat arbitrary. + TOL2 = 10*M*N*EPS + +!............. + + DO K_TRAJ = 1, 2 + ! Number of intial conditions in the simulation/trajectories (1 or 2) + + COND = 1.0D8 + DMAX = 1.0D2 + RSIGN = 'F' + GRADE = 'N' + MODEL = 6 + CONDL = 1.0D2 + MODER = 6 + CONDR = 1.0D2 + PIVTNG = 'N' + + ! Loop over all parameter MODE values for ZLATMR (+1,..,+6) + DO MODE = 1, 6 + + ALLOCATE( IWORK(2*M) ) + ALLOCATE(DR(N)) + CALL DLATMR( M, M, 'S', ISEED, 'N', DA, MODE, COND, & + DMAX, RSIGN, GRADE, DL, MODEL, CONDL, & + DR, MODER, CONDR, PIVTNG, IWORK, M, M, & + ZERO, -ONE, 'N', A, LDA, IWORK(M+1), INFO ) + DEALLOCATE(IWORK) + DEALLOCATE(DR) + + LWORK = 4*M+1 + ALLOCATE(WORK(LWORK)) + AC = A + CALL DGEEV( 'N','V', M, AC, M, REIGA, IEIGA, VA, M, & + VA, M, WORK, LWORK, INFO ) ! LAPACK CALL + DEALLOCATE(WORK) + TMP = ZERO + DO i = 1, M + EIGA(i,1) = REIGA(i) + EIGA(i,2) = IEIGA(i) + TMP = MAX( TMP, SQRT(REIGA(i)**2+IEIGA(i)**2)) + END DO + + ! Scale A to have the desirable spectral radius. + CALL DLASCL( 'G', 0, 0, TMP, ONE, M, M, A, M, INFO ) + CALL DLASCL( 'G', 0, 0, TMP, ONE, M, 2, EIGA, M, INFO ) + + ! Compute the norm of A + ANORM = DLANGE( 'F', N, N, A, M, WDUMMY ) + + IF ( K_TRAJ == 2 ) THEN + ! generate data with two inital conditions + CALL DLARNV(2, ISEED, M, F1(1,1) ) + F1(1:M,1) = 1.0E-10*F1(1:M,1) + DO i = 1, N/2 + CALL DGEMV( 'N', M, M, ONE, A, M, F1(1,i), 1, ZERO, & + F1(1,i+1), 1 ) + END DO + X0(1:M,1:N/2) = F1(1:M,1:N/2) + Y0(1:M,1:N/2) = F1(1:M,2:N/2+1) + + CALL DLARNV(2, ISEED, M, F1(1,1) ) + DO i = 1, N-N/2 + CALL DGEMV( 'N', M, M, ONE, A, M, F1(1,i), 1, ZERO, & + F1(1,i+1), 1 ) + END DO + X0(1:M,N/2+1:N) = F1(1:M,1:N-N/2) + Y0(1:M,N/2+1:N) = F1(1:M,2:N-N/2+1) + ELSE + CALL DLARNV(2, ISEED, M, F(1,1) ) + DO i = 1, N + CALL DGEMV( 'N', M, M, ONE, A, M, F(1,i), 1, ZERO, & + F(1,i+1), 1 ) + END DO + X0(1:M,1:N) = F(1:M,1:N) + Y0(1:M,1:N) = F(1:M,2:N+1) + END IF + + XNORM = DLANGE( 'F', M, N, X0, LDX, WDUMMY ) + YNORM = DLANGE( 'F', M, N, Y0, LDX, WDUMMY ) +!............................................................ + + DO iJOBZ = 1, 4 + + SELECT CASE ( iJOBZ ) + CASE(1) + JOBZ = 'V' ! Ritz vectors will be computed + RESIDS = 'R' ! Residuals will be computed + CASE(2) + JOBZ = 'V' + RESIDS = 'N' + CASE(3) + JOBZ = 'F' ! Ritz vectors in factored form + RESIDS = 'N' + CASE(4) + JOBZ = 'N' + RESIDS = 'N' + END SELECT + + DO iJOBREF = 1, 3 + + SELECT CASE ( iJOBREF ) + CASE(1) + JOBREF = 'R' ! Data for refined Ritz vectors + CASE(2) + JOBREF = 'E' ! Exact DMD vectors + CASE(3) + JOBREF = 'N' + END SELECT + + DO iSCALE = 1, 4 + + SELECT CASE ( iSCALE ) + CASE(1) + SCALE = 'S' ! X data normalized + CASE(2) + SCALE = 'C' ! X normalized, consist. check + CASE(3) + SCALE = 'Y' ! Y data normalized + CASE(4) + SCALE = 'N' + END SELECT + + DO iNRNK = -1, -2, -1 + ! Two truncation strategies. The "-2" case for R&D + ! purposes only - it uses possibly low accuracy small + ! singular values, in which case the formulas used in + ! the DMD are highly sensitive. + NRNK = iNRNK + + DO iWHTSVD = 1, 4 + ! Check all four options to compute the POD basis + ! via the SVD. + WHTSVD = iWHTSVD + + DO LWMINOPT = 1, 2 + ! Workspace query for the minimal (1) and for the optimal + ! (2) workspace lengths determined by workspace query. + + X(1:M,1:N) = X0(1:M,1:N) + Y(1:M,1:N) = Y0(1:M,1:N) + + ! DGEDMD: Workspace query and workspace allocation + CALL DGEDMD( SCALE, JOBZ, RESIDS, JOBREF, WHTSVD, M, & + N, X, LDX, Y, LDY, NRNK, TOL, K, REIG, IEIG, Z, & + LDZ, RES, AU, LDAU, W, LDW, S, LDS, WDUMMY, -1, & + IDUMMY, -1, INFO ) + + LIWORK = IDUMMY(1) + ALLOCATE( IWORK(LIWORK) ) + LWORK = INT(WDUMMY(LWMINOPT)) + ALLOCATE( WORK(LWORK) ) + + ! DGEDMD test: CALL DGEDMD + CALL DGEDMD( SCALE, JOBZ, RESIDS, JOBREF, WHTSVD, M, & + N, X, LDX, Y, LDY, NRNK, TOL, K, REIG, IEIG, Z, & + LDZ, RES, AU, LDAU, W, LDW, S, LDS, WORK, LWORK,& + IWORK, LIWORK, INFO ) + + SINGVX(1:N) = WORK(1:N) + + !...... DGEDMD check point + IF ( LSAME(JOBZ,'V') ) THEN + ! Check that Z = X*W, on return from DGEDMD + ! This checks that the returned aigenvectors in Z are + ! the product of the SVD'POD basis returned in X + ! and the eigenvectors of the rayleigh quotient + ! returned in W + CALL DGEMM( 'N', 'N', M, K, K, ONE, X, LDX, W, LDW, & + ZERO, Z1, LDZ ) + TMP = ZERO + DO i = 1, K + CALL DAXPY( M, -ONE, Z(1,i), 1, Z1(1,i), 1) + TMP = MAX(TMP, DNRM2( M, Z1(1,i), 1 ) ) + END DO + TMP_ZXW = MAX(TMP_ZXW, TMP ) + + IF ( TMP_ZXW > 10*M*EPS ) THEN + NFAIL_Z_XV = NFAIL_Z_XV + 1 + WRITE(*,*) ':( .................DGEDMD FAILED!', & + 'Check the code for implementation errors.' + WRITE(*,*) 'The input parameters were ',& + SCALE, JOBZ, RESIDS, JOBREF, WHTSVD, & + M, N, LDX, LDY, NRNK, TOL + END IF + + END IF + + !...... DGEDMD check point + IF ( LSAME(JOBREF,'R') ) THEN + ! The matrix A*U is returned for computing refined Ritz vectors. + ! Check that A*U is computed correctly using the formula + ! A*U = Y * V * inv(SIGMA). This depends on the + ! accuracy in the computed singular values and vectors of X. + ! See the paper for an error analysis. + ! Note that the left singular vectors of the input matrix X + ! are returned in the array X. + CALL DGEMM( 'N', 'N', M, K, M, ONE, A, LDA, X, LDX, & + ZERO, Z1, LDZ ) + TMP = ZERO + DO i = 1, K + CALL DAXPY( M, -ONE, AU(1,i), 1, Z1(1,i), 1) + TMP = MAX( TMP, DNRM2( M, Z1(1,i),1 ) * & + SINGVX(K)/(ANORM*SINGVX(1)) ) + END DO + TMP_AU = MAX( TMP_AU, TMP ) + + IF ( TMP > TOL2 ) THEN + NFAIL_AU = NFAIL_AU + 1 + WRITE(*,*) ':( .................DGEDMD FAILED!', & + 'Check the code for implementation errors.' + WRITE(*,*) 'The input parameters were ',& + SCALE, JOBZ, RESIDS, JOBREF, WHTSVD, & + M, N, LDX, LDY, NRNK, TOL + END IF + + ELSEIF ( LSAME(JOBREF,'E') ) THEN + ! The unscaled vectors of the Exact DMD are computed. + ! This option is included for the sake of completeness, + ! for users who prefer the Exact DMD vectors. The + ! returned vectors are in the real form, in the same way + ! as the Ritz vectors. Here we just save the vectors + ! and test them separately using a Matlab script. + + CALL DGEMM( 'N', 'N', M, K, M, ONE, A, LDA, AU, LDAU, ZERO, Y1, M ) + i=1 + DO WHILE ( i <= K ) + IF ( IEIG(i) == ZERO ) THEN + ! have a real eigenvalue with real eigenvector + CALL DAXPY( M, -REIG(i), AU(1,i), 1, Y1(1,i), 1 ) + RESEX(i) = DNRM2( M, Y1(1,i), 1) / DNRM2(M,AU(1,i),1) + i = i + 1 + ELSE + ! Have a complex conjugate pair + ! REIG(i) +- sqrt(-1)*IMEIG(i). + ! Since all computation is done in real + ! arithmetic, the formula for the residual + ! is recast for real representation of the + ! complex conjugate eigenpair. See the + ! description of RES. + AB(1,1) = REIG(i) + AB(2,1) = -IEIG(i) + AB(1,2) = IEIG(i) + AB(2,2) = REIG(i) + CALL DGEMM( 'N', 'N', M, 2, 2, -ONE, AU(1,i), & + M, AB, 2, ONE, Y1(1,i), M ) + RESEX(i) = DLANGE( 'F', M, 2, Y1(1,i), M, & + WORK )/ DLANGE( 'F', M, 2, AU(1,i), M, & + WORK ) + RESEX(i+1) = RESEX(i) + i = i + 2 + END IF + END DO + + END IF + + !...... DGEDMD check point + IF ( LSAME(RESIDS, 'R') ) THEN + ! Compare the residuals returned by DGEDMD with the + ! explicitly computed residuals using the matrix A. + ! Compute explicitly Y1 = A*Z + CALL DGEMM( 'N', 'N', M, K, M, ONE, A, LDA, Z, LDZ, ZERO, Y1, M ) + ! ... and then A*Z(:,i) - LAMBDA(i)*Z(:,i), using the real forms + ! of the invariant subspaces that correspond to complex conjugate + ! pairs of eigencalues. (See the description of Z in DGEDMD,) + i = 1 + DO WHILE ( i <= K ) + IF ( IEIG(i) == ZERO ) THEN + ! have a real eigenvalue with real eigenvector + CALL DAXPY( M, -REIG(i), Z(1,i), 1, Y1(1,i), 1 ) + RES1(i) = DNRM2( M, Y1(1,i), 1) + i = i + 1 + ELSE + ! Have a complex conjugate pair + ! REIG(i) +- sqrt(-1)*IMEIG(i). + ! Since all computation is done in real + ! arithmetic, the formula for the residual + ! is recast for real representation of the + ! complex conjugate eigenpair. See the + ! description of RES. + AB(1,1) = REIG(i) + AB(2,1) = -IEIG(i) + AB(1,2) = IEIG(i) + AB(2,2) = REIG(i) + CALL DGEMM( 'N', 'N', M, 2, 2, -ONE, Z(1,i), & + M, AB, 2, ONE, Y1(1,i), M ) + RES1(i) = DLANGE( 'F', M, 2, Y1(1,i), M, & + WORK ) + RES1(i+1) = RES1(i) + i = i + 2 + END IF + END DO + TMP = ZERO + DO i = 1, K + TMP = MAX( TMP, ABS(RES(i) - RES1(i)) * & + SINGVX(K)/(ANORM*SINGVX(1)) ) + END DO + TMP_REZ = MAX( TMP_REZ, TMP ) + + IF ( TMP > TOL2 ) THEN + NFAIL_REZ = NFAIL_REZ + 1 + WRITE(*,*) ':( ..................DGEDMD FAILED!', & + 'Check the code for implementation errors.' + WRITE(*,*) 'The input parameters were ',& + SCALE, JOBZ, RESIDS, JOBREF, WHTSVD, & + M, N, LDX, LDY, NRNK, TOL + END IF + + IF ( LSAME(JOBREF,'E') ) THEN + TMP = ZERO + DO i = 1, K + TMP = MAX( TMP, ABS(RES1(i) - RESEX(i))/(RES1(i)+RESEX(i)) ) + END DO + TMP_EX = MAX(TMP_EX,TMP) + END IF + + END IF + + !..... store the results for inspection + DO i = 1, K + LAMBDA(i,1) = REIG(i) + LAMBDA(i,2) = IEIG(i) + END DO + + DEALLOCATE(IWORK) + DEALLOCATE(WORK) + + !====================================================================== + ! Now test the DGEDMDQ + !====================================================================== + IF ( TEST_QRDMD .AND. (K_TRAJ == 1) ) THEN + RJOBDATA(2) = 1 + F1 = F + + ! DGEDMDQ test: Workspace query and workspace allocation + CALL DGEDMDQ( SCALE, JOBZ, RESIDS, WANTQ, WANTR, & + JOBREF, WHTSVD, M, N+1, F1, LDF, X, LDX, Y, & + LDY, NRNK, TOL, KQ, REIGQ, IEIGQ, Z, LDZ, & + RES, AU, LDAU, W, LDW, S, LDS, WDUMMY, & + -1, IDUMMY, -1, INFO ) + LIWORK = IDUMMY(1) + ALLOCATE( IWORK(LIWORK) ) + LWORK = INT(WDUMMY(LWMINOPT)) + ALLOCATE(WORK(LWORK)) + ! DGEDMDQ test: CALL DGEDMDQ + CALL DGEDMDQ( SCALE, JOBZ, RESIDS, WANTQ, WANTR, & + JOBREF, WHTSVD, M, N+1, F1, LDF, X, LDX, Y, & + LDY, NRNK, TOL, KQ, REIGQ, IEIGQ, Z, LDZ, & + RES, AU, LDAU, W, LDW, S, LDS, & + WORK, LWORK, IWORK, LIWORK, INFO ) + + SINGVQX(1:KQ) = WORK(MIN(M,N+1)+1: MIN(M,N+1)+KQ) + + !..... DGEDMDQ check point + IF ( KQ /= K ) THEN + KDIFF = KDIFF+1 + END IF + + TMP = ZERO + DO i = 1, MIN(K, KQ) + TMP = MAX(TMP, ABS(SINGVX(i)-SINGVQX(i)) / & + SINGVX(1) ) + END DO + SVDIFF = MAX( SVDIFF, TMP ) + IF ( TMP > M*N*EPS ) THEN + WRITE(*,*) 'FAILED! Something was wrong with the run.' + NFAIL_SVDIFF = NFAIL_SVDIFF + 1 + DO j =1, 3 + write(*,*) j, SINGVX(j), SINGVQX(j) + read(*,*) + END DO + END IF + + !..... DGEDMDQ check point + IF ( LSAME(WANTQ,'Q') .AND. LSAME(WANTR,'R') ) THEN + ! Check that the QR factors are computed and returned + ! as requested. The residual ||F-Q*R||_F / ||F||_F + ! is compared to M*N*EPS. + F2 = F + CALL DGEMM( 'N', 'N', M, N+1, MIN(M,N+1), -ONE, F1, & + LDF, Y, LDY, ONE, F2, LDF ) + TMP_FQR = DLANGE( 'F', M, N+1, F2, LDF, WORK ) / & + DLANGE( 'F', M, N+1, F, LDF, WORK ) + IF ( TMP_FQR > TOL2 ) THEN + WRITE(*,*) 'FAILED! Something was wrong with the run.' + NFAIL_F_QR = NFAIL_F_QR + 1 + END IF + END IF + + !..... DGEDMDQ check point + IF ( LSAME(RESIDS, 'R') ) THEN + ! Compare the residuals returned by DGEDMDQ with the + ! explicitly computed residuals using the matrix A. + ! Compute explicitly Y1 = A*Z + CALL DGEMM( 'N', 'N', M, KQ, M, ONE, A, M, Z, M, ZERO, Y1, M ) + ! ... and then A*Z(:,i) - LAMBDA(i)*Z(:,i), using the real forms + ! of the invariant subspaces that correspond to complex conjugate + ! pairs of eigencalues. (See the description of Z in DGEDMDQ) + i = 1 + DO WHILE ( i <= KQ ) + IF ( IEIGQ(i) == ZERO ) THEN + ! have a real eigenvalue with real eigenvector + CALL DAXPY( M, -REIGQ(i), Z(1,i), 1, Y1(1,i), 1 ) + ! Y(1:M,i) = Y(1:M,i) - REIG(i)*Z(1:M,i) + RES1(i) = DNRM2( M, Y1(1,i), 1) + i = i + 1 + ELSE + ! Have a complex conjugate pair + ! REIG(i) +- sqrt(-1)*IMEIG(i). + ! Since all computation is done in real + ! arithmetic, the formula for the residual + ! is recast for real representation of the + ! complex conjugate eigenpair. See the + ! description of RES. + AB(1,1) = REIGQ(i) + AB(2,1) = -IEIGQ(i) + AB(1,2) = IEIGQ(i) + AB(2,2) = REIGQ(i) + CALL DGEMM( 'N', 'N', M, 2, 2, -ONE, Z(1,i), & + M, AB, 2, ONE, Y1(1,i), M ) ! BLAS CALL + ! Y(1:M,i:i+1) = Y(1:M,i:i+1) - Z(1:M,i:i+1) * AB ! INTRINSIC + RES1(i) = DLANGE( 'F', M, 2, Y1(1,i), M, & + WORK ) ! LAPACK CALL + RES1(i+1) = RES1(i) + i = i + 2 + END IF + END DO + TMP = ZERO + DO i = 1, KQ + TMP = MAX( TMP, ABS(RES(i) - RES1(i)) * & + SINGVQX(K)/(ANORM*SINGVQX(1)) ) + END DO + TMP_REZQ = MAX( TMP_REZQ, TMP ) + IF ( TMP > TOL2 ) THEN + NFAIL_REZQ = NFAIL_REZQ + 1 + WRITE(*,*) '................ DGEDMDQ FAILED!', & + 'Check the code for implementation errors.' + STOP + END IF + + END IF + + DO i = 1, KQ + LAMBDAQ(i,1) = REIGQ(i) + LAMBDAQ(i,2) = IEIGQ(i) + END DO + + DEALLOCATE(WORK) + DEALLOCATE(IWORK) + END IF ! TEST_QRDMD +!====================================================================== + + END DO ! LWMINOPT + !write(*,*) 'LWMINOPT loop completed' + END DO ! WHTSVD LOOP + !write(*,*) 'WHTSVD loop completed' + END DO ! NRNK LOOP + !write(*,*) 'NRNK loop completed' + END DO ! SCALE LOOP + !write(*,*) 'SCALE loop completed' + END DO ! JOBF LOOP + !write(*,*) 'JOBREF loop completed' + END DO ! JOBZ LOOP + !write(*,*) 'JOBZ loop completed' + + END DO ! MODE -6:6 + !write(*,*) 'MODE loop completed' + END DO ! 1 or 2 trajectories + !write(*,*) 'trajectories loop completed' + + DEALLOCATE(A) + DEALLOCATE(AC) + DEALLOCATE(DA) + DEALLOCATE(DL) + DEALLOCATE(F) + DEALLOCATE(F1) + DEALLOCATE(F2) + DEALLOCATE(X) + DEALLOCATE(X0) + DEALLOCATE(SINGVX) + DEALLOCATE(SINGVQX) + DEALLOCATE(Y) + DEALLOCATE(Y0) + DEALLOCATE(Y1) + DEALLOCATE(Z) + DEALLOCATE(Z1) + DEALLOCATE(RES) + DEALLOCATE(RES1) + DEALLOCATE(RESEX) + DEALLOCATE(REIG) + DEALLOCATE(IEIG) + DEALLOCATE(REIGQ) + DEALLOCATE(IEIGQ) + DEALLOCATE(REIGA) + DEALLOCATE(IEIGA) + DEALLOCATE(VA) + DEALLOCATE(LAMBDA) + DEALLOCATE(LAMBDAQ) + DEALLOCATE(EIGA) + DEALLOCATE(W) + DEALLOCATE(AU) + DEALLOCATE(S) + +!............................................................ + ! Generate random M-by-M matrix A. Use DLATMR from + END DO ! LLOOP + + WRITE(*,*) '>>>>>>>>>>>>>>>>>>>>>>>>>>' + WRITE(*,*) ' Test summary for DGEDMD :' + WRITE(*,*) '>>>>>>>>>>>>>>>>>>>>>>>>>>' + WRITE(*,*) + IF ( NFAIL_Z_XV == 0 ) THEN + WRITE(*,*) '>>>> Z - U*V test PASSED.' + ELSE + WRITE(*,*) 'Z - U*V test FAILED ', NFAIL_Z_XV, ' time(s)' + WRITE(*,*) 'Max error ||Z-U*V||_F was ', TMP_ZXW + NFAIL_TOTAL = NFAIL_TOTAL + NFAIL_Z_XV + END IF + IF ( NFAIL_AU == 0 ) THEN + WRITE(*,*) '>>>> A*U test PASSED. ' + ELSE + WRITE(*,*) 'A*U test FAILED ', NFAIL_AU, ' time(s)' + WRITE(*,*) 'Max A*U test adjusted error measure was ', TMP_AU + WRITE(*,*) 'It should be up to O(M*N) times EPS, EPS = ', EPS + NFAIL_TOTAL = NFAIL_TOTAL + NFAIL_AU + END IF + + IF ( NFAIL_REZ == 0 ) THEN + WRITE(*,*) '>>>> Rezidual computation test PASSED.' + ELSE + WRITE(*,*) 'Rezidual computation test FAILED ', NFAIL_REZ, 'time(s)' + WRITE(*,*) 'Max residual computing test adjusted error measure was ', TMP_REZ + WRITE(*,*) 'It should be up to O(M*N) times EPS, EPS = ', EPS + NFAIL_TOTAL = NFAIL_TOTAL + NFAIL_REZ + END IF + + IF ( NFAIL_TOTAL == 0 ) THEN + WRITE(*,*) '>>>> DGEDMD :: ALL TESTS PASSED.' + ELSE + WRITE(*,*) NFAIL_TOTAL, 'FAILURES!' + WRITE(*,*) '>>>>>>>>>>>>>> DGEDMD :: TESTS FAILED. CHECK THE IMPLEMENTATION.' + END IF + + IF ( TEST_QRDMD ) THEN + WRITE(*,*) + WRITE(*,*) '>>>>>>>>>>>>>>>>>>>>>>>>>>' + WRITE(*,*) ' Test summary for DGEDMDQ :' + WRITE(*,*) '>>>>>>>>>>>>>>>>>>>>>>>>>>' + WRITE(*,*) + + IF ( NFAIL_SVDIFF == 0 ) THEN + WRITE(*,*) '>>>> DGEDMD and DGEDMDQ computed singular & + &values test PASSED.' + ELSE + WRITE(*,*) 'DGEDMD and DGEDMDQ discrepancies in & + &the singular values unacceptable ', & + NFAIL_SVDIFF, ' times. Test FAILED.' + WRITE(*,*) 'The maximal discrepancy in the singular values (relative to the norm) was ', SVDIFF + WRITE(*,*) 'It should be up to O(M*N) times EPS, EPS = ', EPS + NFAILQ_TOTAL = NFAILQ_TOTAL + NFAIL_SVDIFF + END IF + + IF ( NFAIL_F_QR == 0 ) THEN + WRITE(*,*) '>>>> F - Q*R test PASSED.' + ELSE + WRITE(*,*) 'F - Q*R test FAILED ', NFAIL_F_QR, ' time(s)' + WRITE(*,*) 'The largest relative residual was ', TMP_FQR + WRITE(*,*) 'It should be up to O(M*N) times EPS, EPS = ', EPS + NFAILQ_TOTAL = NFAILQ_TOTAL + NFAIL_F_QR + END IF + + IF ( NFAIL_REZQ == 0 ) THEN + WRITE(*,*) '>>>> Rezidual computation test PASSED.' + ELSE + WRITE(*,*) 'Rezidual computation test FAILED ', NFAIL_REZQ, 'time(s)' + WRITE(*,*) 'Max residual computing test adjusted error measure was ', TMP_REZQ + WRITE(*,*) 'It should be up to O(M*N) times EPS, EPS = ', EPS + NFAILQ_TOTAL = NFAILQ_TOTAL + NFAIL_REZQ + END IF + + IF ( NFAILQ_TOTAL == 0 ) THEN + WRITE(*,*) '>>>>>>> DGEDMDQ :: ALL TESTS PASSED.' + ELSE + WRITE(*,*) NFAILQ_TOTAL, 'FAILURES!' + WRITE(*,*) '>>>>>>> DGEDMDQ :: TESTS FAILED. CHECK THE IMPLEMENTATION.' + END IF + + END IF + + WRITE(*,*) + WRITE(*,*) 'Test completed.' + STOP + END diff --git a/lapack-netlib/TESTING/EIG/schkdmd.f90 b/lapack-netlib/TESTING/EIG/schkdmd.f90 new file mode 100644 index 000000000..77e3e46c0 --- /dev/null +++ b/lapack-netlib/TESTING/EIG/schkdmd.f90 @@ -0,0 +1,792 @@ +! This is a test program for checking the implementations of +! the implementations of the following subroutines +! +! SGEDMD for computation of the +! Dynamic Mode Decomposition (DMD) +! SGEDMDQ for computation of a +! QR factorization based compressed DMD +! +! Developed and supported by: +! =========================== +! Developed and coded by Zlatko Drmac, Faculty of Science, +! University of Zagreb; drmac@math.hr +! In cooperation with +! AIMdyn Inc., Santa Barbara, CA. +! ======================================================== +! How to run the code (compiler, link info) +! ======================================================== +! Compile as FORTRAN 90 (or later) and link with BLAS and +! LAPACK libraries. +! NOTE: The code is developed and tested on top of the +! Intel MKL library (versions 2022.0.3 and 2022.2.0), +! using the Intel Fortran compiler. +! +! For developers of the C++ implementation +! ======================================================== +! See the LAPACK++ and Template Numerical Toolkit (TNT) +! +! Note on a development of the GPU HP implementation +! ======================================================== +! Work in progress. See CUDA, MAGMA, SLATE. +! NOTE: The four SVD subroutines used in this code are +! included as a part of R&D and for the completeness. +! This was also an opportunity to test those SVD codes. +! If the scaling option is used all four are essentially +! equally good. For implementations on HP platforms, +! one can use whichever SVD is available. +!... ......................................................... +! NOTE: +! When using the Intel MKL 2022.0.3 the subroutine xGESVDQ +! (optionally used in xGEDMD) may cause access violation +! error for x = S, D, C, Z, but only if called with the +! work space query. (At least in our Windows 10 MSVS 2019.) +! The problem can be mitigated by downloading the source +! code of xGESVDQ from the LAPACK repository and use it +! localy instead of the one in the MKL. This seems to +! indicate that the problem is indeed in the MKL. +! This problem did not appear whith Intel MKL 2022.2.0. +! +! NOTE: +! xGESDD seems to have a problem with workspace. In some +! cases the length of the optimal workspace is returned +! smaller than the minimal workspace, as specified in the +! code. As a precaution, all optimal workspaces are +! set as MAX(minimal, optimal). +! Latest implementations of complex xGESDD have different +! length of the real worksapce. We use max value over +! two versions. +!............................................................ +!............................................................ +! + PROGRAM DMD_TEST + use iso_fortran_env, only: real32 + IMPLICIT NONE + integer, parameter :: WP = real32 + +!............................................................ + REAL(KIND=WP), PARAMETER :: ONE = 1.0_WP + REAL(KIND=WP), PARAMETER :: ZERO = 0.0_WP +!............................................................ + REAL(KIND=WP), ALLOCATABLE, DIMENSION(:,:) :: & + A, AC, EIGA, LAMBDA, LAMBDAQ, F, F1, F2,& + Z, Z1, S, AU, W, VA, X, X0, Y, Y0, Y1 + REAL(KIND=WP), ALLOCATABLE, DIMENSION(:) :: & + DA, DL, DR, REIG, REIGA, REIGQ, IEIG, & + IEIGA, IEIGQ, RES, RES1, RESEX, SINGVX,& + SINGVQX, WORK + INTEGER , ALLOCATABLE, DIMENSION(:) :: IWORK + REAL(KIND=WP) :: AB(2,2), WDUMMY(2) + INTEGER :: IDUMMY(2), ISEED(4), RJOBDATA(8) + REAL(KIND=WP) :: ANORM, COND, CONDL, CONDR, DMAX, EPS, & + TOL, TOL2, SVDIFF, TMP, TMP_AU, & + TMP_FQR, TMP_REZ, TMP_REZQ, TMP_ZXW, & + TMP_EX, XNORM, YNORM +!............................................................ + INTEGER :: K, KQ, LDF, LDS, LDA, LDAU, LDW, LDX, LDY, & + LDZ, LIWORK, LWORK, M, N, L, LLOOP, NRNK + INTEGER :: i, iJOBREF, iJOBZ, iSCALE, INFO, KDIFF, & + NFAIL, NFAIL_AU, NFAIL_F_QR, NFAIL_REZ, & + NFAIL_REZQ, NFAIL_SVDIFF, NFAIL_TOTAL, NFAILQ_TOTAL, & + NFAIL_Z_XV, MODE, MODEL, MODER, WHTSVD + INTEGER iNRNK, iWHTSVD, K_TRAJ, LWMINOPT + CHARACTER(LEN=1) GRADE, JOBREF, JOBZ, PIVTNG, RSIGN, & + SCALE, RESIDS, WANTQ, WANTR + + LOGICAL TEST_QRDMD +!..... external subroutines (BLAS and LAPACK) + EXTERNAL SAXPY, SGEEV, SGEMM, SGEMV, SLACPY, SLASCL + EXTERNAL SLARNV, SLATMR +!.....external subroutines DMD package, part 1 +! subroutines under test + EXTERNAL SGEDMD, SGEDMDQ + +!..... external functions (BLAS and LAPACK) + EXTERNAL SLAMCH, SLANGE, SNRM2 + REAL(KIND=WP) :: SLAMCH, SLANGE, SNRM2 + EXTERNAL LSAME + LOGICAL LSAME + + INTRINSIC ABS, INT, MIN, MAX +!............................................................ + + ! The test is always in pairs : ( SGEDMD and SGEDMDQ ) + ! because the test includes comparing the results (in pairs). +!..................................................................................... + TEST_QRDMD = .TRUE. ! This code by default performs tests on SGEDMDQ + ! Since the QR factorizations based algorithm is designed for + ! single trajectory data, only single trajectory tests will + ! be performed with xGEDMDQ. + WANTQ = 'Q' + WANTR = 'R' +!................................................................................. + + EPS = SLAMCH( 'P' ) ! machine precision SP + + ! Global counters of failures of some particular tests + NFAIL = 0 + NFAIL_REZ = 0 + NFAIL_REZQ = 0 + NFAIL_Z_XV = 0 + NFAIL_F_QR = 0 + NFAIL_AU = 0 + KDIFF = 0 + NFAIL_SVDIFF = 0 + NFAIL_TOTAL = 0 + NFAILQ_TOTAL = 0 + + + DO LLOOP = 1, 4 + + WRITE(*,*) 'L Loop Index = ', LLOOP + + ! Set the dimensions of the problem ... + WRITE(*,*) 'M = ' + READ(*,*) M + WRITE(*,*) M + ! ... and the number of snapshots. + WRITE(*,*) 'N = ' + READ(*,*) N + WRITE(*,*) N + + ! ... Test the dimensions + IF ( ( MIN(M,N) == 0 ) .OR. ( M < N ) ) THEN + WRITE(*,*) 'Bad dimensions. Required: M >= N > 0.' + STOP + END IF +!............. + ! The seed inside the LLOOP so that each pass can be reproduced easily. + + ISEED(1) = 4 + ISEED(2) = 3 + ISEED(3) = 2 + ISEED(4) = 1 + + LDA = M + LDF = M + LDX = MAX(M,N+1) + LDY = MAX(M,N+1) + LDW = N + LDZ = M + LDAU = MAX(M,N+1) + LDS = N + + TMP_ZXW = ZERO + TMP_AU = ZERO + TMP_REZ = ZERO + TMP_REZQ = ZERO + SVDIFF = ZERO + TMP_EX = ZERO + + ! + ! Test the subroutines on real data snapshots. All + ! computation is done in real arithmetic, even when + ! Koopman eigenvalues and modes are real. + ! + ! Allocate memory space + ALLOCATE( A(LDA,M) ) + ALLOCATE( AC(LDA,M) ) + ALLOCATE( DA(M) ) + ALLOCATE( DL(M) ) + ALLOCATE( F(LDF,N+1) ) + ALLOCATE( F1(LDF,N+1) ) + ALLOCATE( F2(LDF,N+1) ) + ALLOCATE( X(LDX,N) ) + ALLOCATE( X0(LDX,N) ) + ALLOCATE( SINGVX(N) ) + ALLOCATE( SINGVQX(N) ) + ALLOCATE( Y(LDY,N+1) ) + ALLOCATE( Y0(LDY,N+1) ) + ALLOCATE( Y1(M,N+1) ) + ALLOCATE( Z(LDZ,N) ) + ALLOCATE( Z1(LDZ,N) ) + ALLOCATE( RES(N) ) + ALLOCATE( RES1(N) ) + ALLOCATE( RESEX(N) ) + ALLOCATE( REIG(N) ) + ALLOCATE( IEIG(N) ) + ALLOCATE( REIGQ(N) ) + ALLOCATE( IEIGQ(N) ) + ALLOCATE( REIGA(M) ) + ALLOCATE( IEIGA(M) ) + ALLOCATE( VA(LDA,M) ) + ALLOCATE( LAMBDA(N,2) ) + ALLOCATE( LAMBDAQ(N,2) ) + ALLOCATE( EIGA(M,2) ) + ALLOCATE( W(LDW,N) ) + ALLOCATE( AU(LDAU,N) ) + ALLOCATE( S(N,N) ) + + TOL = M*EPS + ! This mimics O(M*N)*EPS bound for accumulated roundoff error. + ! The factor 10 is somewhat arbitrary. + TOL2 = 10*M*N*EPS + +!............. + + DO K_TRAJ = 1, 2 + ! Number of intial conditions in the simulation/trajectories (1 or 2) + + COND = 1.0D8 + DMAX = 1.0D2 + RSIGN = 'F' + GRADE = 'N' + MODEL = 6 + CONDL = 1.0D2 + MODER = 6 + CONDR = 1.0D2 + PIVTNG = 'N' + + ! Loop over all parameter MODE values for ZLATMR (+1,..,+6) + DO MODE = 1, 6 + + ALLOCATE( IWORK(2*M) ) + ALLOCATE(DR(N)) + CALL SLATMR( M, M, 'S', ISEED, 'N', DA, MODE, COND, & + DMAX, RSIGN, GRADE, DL, MODEL, CONDL, & + DR, MODER, CONDR, PIVTNG, IWORK, M, M, & + ZERO, -ONE, 'N', A, LDA, IWORK(M+1), INFO ) + DEALLOCATE(IWORK) + DEALLOCATE(DR) + + LWORK = 4*M+1 + ALLOCATE(WORK(LWORK)) + AC = A + CALL SGEEV( 'N','V', M, AC, M, REIGA, IEIGA, VA, M, & + VA, M, WORK, LWORK, INFO ) ! LAPACK CALL + DEALLOCATE(WORK) + TMP = ZERO + DO i = 1, M + EIGA(i,1) = REIGA(i) + EIGA(i,2) = IEIGA(i) + TMP = MAX( TMP, SQRT(REIGA(i)**2+IEIGA(i)**2)) + END DO + + ! Scale A to have the desirable spectral radius. + CALL SLASCL( 'G', 0, 0, TMP, ONE, M, M, A, M, INFO ) + CALL SLASCL( 'G', 0, 0, TMP, ONE, M, 2, EIGA, M, INFO ) + + ! Compute the norm of A + ANORM = SLANGE( 'F', N, N, A, M, WDUMMY ) + + IF ( K_TRAJ == 2 ) THEN + ! generate data with two inital conditions + CALL SLARNV(2, ISEED, M, F1(1,1) ) + F1(1:M,1) = 1.0E-10*F1(1:M,1) + DO i = 1, N/2 + CALL SGEMV( 'N', M, M, ONE, A, M, F1(1,i), 1, ZERO, & + F1(1,i+1), 1 ) + END DO + X0(1:M,1:N/2) = F1(1:M,1:N/2) + Y0(1:M,1:N/2) = F1(1:M,2:N/2+1) + + CALL SLARNV(2, ISEED, M, F1(1,1) ) + DO i = 1, N-N/2 + CALL SGEMV( 'N', M, M, ONE, A, M, F1(1,i), 1, ZERO, & + F1(1,i+1), 1 ) + END DO + X0(1:M,N/2+1:N) = F1(1:M,1:N-N/2) + Y0(1:M,N/2+1:N) = F1(1:M,2:N-N/2+1) + ELSE + ! single trajectory + CALL SLARNV(2, ISEED, M, F(1,1) ) + DO i = 1, N + CALL SGEMV( 'N', M, M, ONE, A, M, F(1,i), 1, ZERO, & + F(1,i+1), 1 ) + END DO + X0(1:M,1:N) = F(1:M,1:N) + Y0(1:M,1:N) = F(1:M,2:N+1) + END IF + + XNORM = SLANGE( 'F', M, N, X0, LDX, WDUMMY ) + YNORM = SLANGE( 'F', M, N, Y0, LDX, WDUMMY ) +!............................................................ + + DO iJOBZ = 1, 4 + + SELECT CASE ( iJOBZ ) + CASE(1) + JOBZ = 'V' ! Ritz vectors will be computed + RESIDS = 'R' ! Residuals will be computed + CASE(2) + JOBZ = 'V' + RESIDS = 'N' + CASE(3) + JOBZ = 'F' ! Ritz vectors in factored form + RESIDS = 'N' + CASE(4) + JOBZ = 'N' + RESIDS = 'N' + END SELECT + + DO iJOBREF = 1, 3 + + SELECT CASE ( iJOBREF ) + CASE(1) + JOBREF = 'R' ! Data for refined Ritz vectors + CASE(2) + JOBREF = 'E' ! Exact DMD vectors + CASE(3) + JOBREF = 'N' + END SELECT + + DO iSCALE = 1, 4 + + SELECT CASE ( iSCALE ) + CASE(1) + SCALE = 'S' ! X data normalized + CASE(2) + SCALE = 'C' ! X normalized, consist. check + CASE(3) + SCALE = 'Y' ! Y data normalized + CASE(4) + SCALE = 'N' + END SELECT + + DO iNRNK = -1, -2, -1 + ! Two truncation strategies. The "-2" case for R&D + ! purposes only - it uses possibly low accuracy small + ! singular values, in which case the formulas used in + ! the DMD are highly sensitive. + NRNK = iNRNK + + DO iWHTSVD = 1, 4 + ! Check all four options to compute the POD basis + ! via the SVD. + WHTSVD = iWHTSVD + + DO LWMINOPT = 1, 2 + ! Workspace query for the minimal (1) and for the optimal + ! (2) workspace lengths determined by workspace query. + + X(1:M,1:N) = X0(1:M,1:N) + Y(1:M,1:N) = Y0(1:M,1:N) + + ! SGEDMD: Workspace query and workspace allocation + CALL SGEDMD( SCALE, JOBZ, RESIDS, JOBREF, WHTSVD, M, & + N, X, LDX, Y, LDY, NRNK, TOL, K, REIG, IEIG, Z, & + LDZ, RES, AU, LDAU, W, LDW, S, LDS, WDUMMY, -1, & + IDUMMY, -1, INFO ) + + LIWORK = IDUMMY(1) + ALLOCATE( IWORK(LIWORK) ) + LWORK = INT(WDUMMY(LWMINOPT)) + ALLOCATE( WORK(LWORK) ) + + ! SGEDMD test: CALL SGEDMD + CALL SGEDMD( SCALE, JOBZ, RESIDS, JOBREF, WHTSVD, M, & + N, X, LDX, Y, LDY, NRNK, TOL, K, REIG, IEIG, Z, & + LDZ, RES, AU, LDAU, W, LDW, S, LDS, WORK, LWORK,& + IWORK, LIWORK, INFO ) + + SINGVX(1:N) = WORK(1:N) + + !...... SGEDMD check point + IF ( LSAME(JOBZ,'V') ) THEN + ! Check that Z = X*W, on return from SGEDMD + ! This checks that the returned aigenvectors in Z are + ! the product of the SVD'POD basis returned in X + ! and the eigenvectors of the rayleigh quotient + ! returned in W + CALL SGEMM( 'N', 'N', M, K, K, ONE, X, LDX, W, LDW, & + ZERO, Z1, LDZ ) + TMP = ZERO + DO i = 1, K + CALL SAXPY( M, -ONE, Z(1,i), 1, Z1(1,i), 1) + TMP = MAX(TMP, SNRM2( M, Z1(1,i), 1 ) ) + END DO + TMP_ZXW = MAX(TMP_ZXW, TMP ) + + IF ( TMP_ZXW > 10*M*EPS ) THEN + NFAIL_Z_XV = NFAIL_Z_XV + 1 + END IF + + END IF + + !...... SGEDMD check point + IF ( LSAME(JOBREF,'R') ) THEN + ! The matrix A*U is returned for computing refined Ritz vectors. + ! Check that A*U is computed correctly using the formula + ! A*U = Y * V * inv(SIGMA). This depends on the + ! accuracy in the computed singular values and vectors of X. + ! See the paper for an error analysis. + ! Note that the left singular vectors of the input matrix X + ! are returned in the array X. + CALL SGEMM( 'N', 'N', M, K, M, ONE, A, LDA, X, LDX, & + ZERO, Z1, LDZ ) + TMP = ZERO + DO i = 1, K + CALL SAXPY( M, -ONE, AU(1,i), 1, Z1(1,i), 1) + TMP = MAX( TMP, SNRM2( M, Z1(1,i),1 ) * & + SINGVX(K)/(ANORM*SINGVX(1)) ) + END DO + TMP_AU = MAX( TMP_AU, TMP ) + + IF ( TMP > TOL2 ) THEN + NFAIL_AU = NFAIL_AU + 1 + END IF + + ELSEIF ( LSAME(JOBREF,'E') ) THEN + ! The unscaled vectors of the Exact DMD are computed. + ! This option is included for the sake of completeness, + ! for users who prefer the Exact DMD vectors. The + ! returned vectors are in the real form, in the same way + ! as the Ritz vectors. Here we just save the vectors + ! and test them separately using a Matlab script. + + CALL SGEMM( 'N', 'N', M, K, M, ONE, A, LDA, AU, LDAU, ZERO, Y1, M ) + i=1 + DO WHILE ( i <= K ) + IF ( IEIG(i) == ZERO ) THEN + ! have a real eigenvalue with real eigenvector + CALL SAXPY( M, -REIG(i), AU(1,i), 1, Y1(1,i), 1 ) + RESEX(i) = SNRM2( M, Y1(1,i), 1) / SNRM2(M,AU(1,i),1) + i = i + 1 + ELSE + ! Have a complex conjugate pair + ! REIG(i) +- sqrt(-1)*IMEIG(i). + ! Since all computation is done in real + ! arithmetic, the formula for the residual + ! is recast for real representation of the + ! complex conjugate eigenpair. See the + ! description of RES. + AB(1,1) = REIG(i) + AB(2,1) = -IEIG(i) + AB(1,2) = IEIG(i) + AB(2,2) = REIG(i) + CALL SGEMM( 'N', 'N', M, 2, 2, -ONE, AU(1,i), & + M, AB, 2, ONE, Y1(1,i), M ) + RESEX(i) = SLANGE( 'F', M, 2, Y1(1,i), M, & + WORK )/ SLANGE( 'F', M, 2, AU(1,i), M, & + WORK ) + RESEX(i+1) = RESEX(i) + i = i + 2 + END IF + END DO + + END IF + + !...... SGEDMD check point + IF ( LSAME(RESIDS, 'R') ) THEN + ! Compare the residuals returned by SGEDMD with the + ! explicitly computed residuals using the matrix A. + ! Compute explicitly Y1 = A*Z + CALL SGEMM( 'N', 'N', M, K, M, ONE, A, LDA, Z, LDZ, ZERO, Y1, M ) + ! ... and then A*Z(:,i) - LAMBDA(i)*Z(:,i), using the real forms + ! of the invariant subspaces that correspond to complex conjugate + ! pairs of eigencalues. (See the description of Z in SGEDMD,) + i = 1 + DO WHILE ( i <= K ) + IF ( IEIG(i) == ZERO ) THEN + ! have a real eigenvalue with real eigenvector + CALL SAXPY( M, -REIG(i), Z(1,i), 1, Y1(1,i), 1 ) + RES1(i) = SNRM2( M, Y1(1,i), 1) + i = i + 1 + ELSE + ! Have a complex conjugate pair + ! REIG(i) +- sqrt(-1)*IMEIG(i). + ! Since all computation is done in real + ! arithmetic, the formula for the residual + ! is recast for real representation of the + ! complex conjugate eigenpair. See the + ! description of RES. + AB(1,1) = REIG(i) + AB(2,1) = -IEIG(i) + AB(1,2) = IEIG(i) + AB(2,2) = REIG(i) + CALL SGEMM( 'N', 'N', M, 2, 2, -ONE, Z(1,i), & + M, AB, 2, ONE, Y1(1,i), M ) + RES1(i) = SLANGE( 'F', M, 2, Y1(1,i), M, & + WORK ) + RES1(i+1) = RES1(i) + i = i + 2 + END IF + END DO + TMP = ZERO + DO i = 1, K + TMP = MAX( TMP, ABS(RES(i) - RES1(i)) * & + SINGVX(K)/(ANORM*SINGVX(1)) ) + END DO + TMP_REZ = MAX( TMP_REZ, TMP ) + + IF ( TMP > TOL2 ) THEN + NFAIL_REZ = NFAIL_REZ + 1 + END IF + + IF ( LSAME(JOBREF,'E') ) THEN + TMP = ZERO + DO i = 1, K + TMP = MAX( TMP, ABS(RES1(i) - RESEX(i))/(RES1(i)+RESEX(i)) ) + END DO + TMP_EX = MAX(TMP_EX,TMP) + END IF + + END IF + + ! ... store the results for inspection + DO i = 1, K + LAMBDA(i,1) = REIG(i) + LAMBDA(i,2) = IEIG(i) + END DO + + DEALLOCATE(IWORK) + DEALLOCATE(WORK) + + !====================================================================== + ! Now test the SGEDMDQ, if requested. + !====================================================================== + IF ( TEST_QRDMD .AND. (K_TRAJ == 1) ) THEN + RJOBDATA(2) = 1 + F1 = F + + ! SGEDMDQ test: Workspace query and workspace allocation + CALL SGEDMDQ( SCALE, JOBZ, RESIDS, WANTQ, WANTR, & + JOBREF, WHTSVD, M, N+1, F1, LDF, X, LDX, Y, & + LDY, NRNK, TOL, KQ, REIGQ, IEIGQ, Z, LDZ, & + RES, AU, LDAU, W, LDW, S, LDS, WDUMMY, & + -1, IDUMMY, -1, INFO ) + LIWORK = IDUMMY(1) + ALLOCATE( IWORK(LIWORK) ) + LWORK = INT(WDUMMY(LWMINOPT)) + ALLOCATE(WORK(LWORK)) + + ! SGEDMDQ test: CALL SGEDMDQ + CALL SGEDMDQ( SCALE, JOBZ, RESIDS, WANTQ, WANTR, & + JOBREF, WHTSVD, M, N+1, F1, LDF, X, LDX, Y, & + LDY, NRNK, TOL, KQ, REIGQ, IEIGQ, Z, LDZ, & + RES, AU, LDAU, W, LDW, S, LDS, & + WORK, LWORK, IWORK, LIWORK, INFO ) + + SINGVQX(1:KQ) = WORK(MIN(M,N+1)+1: MIN(M,N+1)+KQ) + + !..... SGEDMDQ check point + IF ( KQ /= K ) THEN + KDIFF = KDIFF+1 + END IF + + TMP = ZERO + DO i = 1, MIN(K, KQ) + TMP = MAX(TMP, ABS(SINGVX(i)-SINGVQX(i)) / & + SINGVX(1) ) + END DO + SVDIFF = MAX( SVDIFF, TMP ) + IF ( TMP > M*N*EPS ) THEN + NFAIL_SVDIFF = NFAIL_SVDIFF + 1 + END IF + + !..... SGEDMDQ check point + IF ( LSAME(WANTQ,'Q') .AND. LSAME(WANTR,'R') ) THEN + ! Check that the QR factors are computed and returned + ! as requested. The residual ||F-Q*R||_F / ||F||_F + ! is compared to M*N*EPS. + F2 = F + CALL SGEMM( 'N', 'N', M, N+1, MIN(M,N+1), -ONE, F1, & + LDF, Y, LDY, ONE, F2, LDF ) + TMP_FQR = SLANGE( 'F', M, N+1, F2, LDF, WORK ) / & + SLANGE( 'F', M, N+1, F, LDF, WORK ) + IF ( TMP_FQR > TOL2 ) THEN + NFAIL_F_QR = NFAIL_F_QR + 1 + END IF + END IF + + !..... SGEDMDQ checkpoint + IF ( LSAME(RESIDS, 'R') ) THEN + ! Compare the residuals returned by SGEDMDQ with the + ! explicitly computed residuals using the matrix A. + ! Compute explicitly Y1 = A*Z + CALL SGEMM( 'N', 'N', M, KQ, M, ONE, A, M, Z, M, ZERO, Y1, M ) + ! ... and then A*Z(:,i) - LAMBDA(i)*Z(:,i), using the real forms + ! of the invariant subspaces that correspond to complex conjugate + ! pairs of eigencalues. (See the description of Z in SGEDMDQ) + i = 1 + DO WHILE ( i <= KQ ) + IF ( IEIGQ(i) == ZERO ) THEN + ! have a real eigenvalue with real eigenvector + CALL SAXPY( M, -REIGQ(i), Z(1,i), 1, Y1(1,i), 1 ) + ! Y(1:M,i) = Y(1:M,i) - REIG(i)*Z(1:M,i) + RES1(i) = SNRM2( M, Y1(1,i), 1) + i = i + 1 + ELSE + ! Have a complex conjugate pair + ! REIG(i) +- sqrt(-1)*IMEIG(i). + ! Since all computation is done in real + ! arithmetic, the formula for the residual + ! is recast for real representation of the + ! complex conjugate eigenpair. See the + ! description of RES. + AB(1,1) = REIGQ(i) + AB(2,1) = -IEIGQ(i) + AB(1,2) = IEIGQ(i) + AB(2,2) = REIGQ(i) + CALL SGEMM( 'N', 'N', M, 2, 2, -ONE, Z(1,i), & + M, AB, 2, ONE, Y1(1,i), M ) ! BLAS CALL + ! Y(1:M,i:i+1) = Y(1:M,i:i+1) - Z(1:M,i:i+1) * AB ! INTRINSIC + RES1(i) = SLANGE( 'F', M, 2, Y1(1,i), M, & + WORK ) ! LAPACK CALL + RES1(i+1) = RES1(i) + i = i + 2 + END IF + END DO + TMP = ZERO + DO i = 1, KQ + TMP = MAX( TMP, ABS(RES(i) - RES1(i)) * & + SINGVQX(K)/(ANORM*SINGVQX(1)) ) + END DO + TMP_REZQ = MAX( TMP_REZQ, TMP ) + IF ( TMP > TOL2 ) THEN + NFAIL_REZQ = NFAIL_REZQ + 1 + END IF + + END IF + + DO i = 1, KQ + LAMBDAQ(i,1) = REIGQ(i) + LAMBDAQ(i,2) = IEIGQ(i) + END DO + + DEALLOCATE(WORK) + DEALLOCATE(IWORK) + END IF ! TEST_QRDMD +!====================================================================== + + END DO ! LWMINOPT + !write(*,*) 'LWMINOPT loop completed' + END DO ! WHTSVD LOOP + !write(*,*) 'WHTSVD loop completed' + END DO ! NRNK LOOP + !write(*,*) 'NRNK loop completed' + END DO ! SCALE LOOP + !write(*,*) 'SCALE loop completed' + END DO ! JOBF LOOP + !write(*,*) 'JOBREF loop completed' + END DO ! JOBZ LOOP + !write(*,*) 'JOBZ loop completed' + + END DO ! MODE -6:6 + !write(*,*) 'MODE loop completed' + END DO ! 1 or 2 trajectories + !write(*,*) 'trajectories loop completed' + + DEALLOCATE(A) + DEALLOCATE(AC) + DEALLOCATE(DA) + DEALLOCATE(DL) + DEALLOCATE(F) + DEALLOCATE(F1) + DEALLOCATE(F2) + DEALLOCATE(X) + DEALLOCATE(X0) + DEALLOCATE(SINGVX) + DEALLOCATE(SINGVQX) + DEALLOCATE(Y) + DEALLOCATE(Y0) + DEALLOCATE(Y1) + DEALLOCATE(Z) + DEALLOCATE(Z1) + DEALLOCATE(RES) + DEALLOCATE(RES1) + DEALLOCATE(RESEX) + DEALLOCATE(REIG) + DEALLOCATE(IEIG) + DEALLOCATE(REIGQ) + DEALLOCATE(IEIGQ) + DEALLOCATE(REIGA) + DEALLOCATE(IEIGA) + DEALLOCATE(VA) + DEALLOCATE(LAMBDA) + DEALLOCATE(LAMBDAQ) + DEALLOCATE(EIGA) + DEALLOCATE(W) + DEALLOCATE(AU) + DEALLOCATE(S) + +!............................................................ + ! Generate random M-by-M matrix A. Use DLATMR from + END DO ! LLOOP + + + WRITE(*,*) '>>>>>>>>>>>>>>>>>>>>>>>>>>' + WRITE(*,*) ' Test summary for SGEDMD :' + WRITE(*,*) '>>>>>>>>>>>>>>>>>>>>>>>>>>' + WRITE(*,*) + IF ( NFAIL_Z_XV == 0 ) THEN + WRITE(*,*) '>>>> Z - U*V test PASSED.' + ELSE + WRITE(*,*) 'Z - U*V test FAILED ', NFAIL_Z_XV, ' time(s)' + WRITE(*,*) 'Max error ||Z-U*V||_F was ', TMP_ZXW + NFAIL_TOTAL = NFAIL_TOTAL + NFAIL_Z_XV + END IF + IF ( NFAIL_AU == 0 ) THEN + WRITE(*,*) '>>>> A*U test PASSED. ' + ELSE + WRITE(*,*) 'A*U test FAILED ', NFAIL_AU, ' time(s)' + WRITE(*,*) 'Max A*U test adjusted error measure was ', TMP_AU + WRITE(*,*) 'It should be up to O(M*N) times EPS, EPS = ', EPS + NFAIL_TOTAL = NFAIL_TOTAL + NFAIL_AU + END IF + + IF ( NFAIL_REZ == 0 ) THEN + WRITE(*,*) '>>>> Rezidual computation test PASSED.' + ELSE + WRITE(*,*) 'Rezidual computation test FAILED ', NFAIL_REZ, 'time(s)' + WRITE(*,*) 'Max residual computing test adjusted error measure was ', TMP_REZ + WRITE(*,*) 'It should be up to O(M*N) times EPS, EPS = ', EPS + NFAIL_TOTAL = NFAIL_TOTAL + NFAIL_REZ + END IF + + IF ( NFAIL_TOTAL == 0 ) THEN + WRITE(*,*) '>>>> SGEDMD :: ALL TESTS PASSED.' + ELSE + WRITE(*,*) NFAIL_TOTAL, 'FAILURES!' + WRITE(*,*) '>>>>>>>>>>>>>> SGEDMD :: TESTS FAILED. CHECK THE IMPLEMENTATION.' + END IF + + IF ( TEST_QRDMD ) THEN + WRITE(*,*) + WRITE(*,*) '>>>>>>>>>>>>>>>>>>>>>>>>>>' + WRITE(*,*) ' Test summary for SGEDMDQ :' + WRITE(*,*) '>>>>>>>>>>>>>>>>>>>>>>>>>>' + WRITE(*,*) + + IF ( NFAIL_SVDIFF == 0 ) THEN + WRITE(*,*) '>>>> SGEDMD and SGEDMDQ computed singular & + &values test PASSED.' + ELSE + WRITE(*,*) 'SGEDMD and SGEDMDQ discrepancies in & + &the singular values unacceptable ', & + NFAIL_SVDIFF, ' times. Test FAILED.' + WRITE(*,*) 'The maximal discrepancy in the singular values (relative to the norm) was ', SVDIFF + WRITE(*,*) 'It should be up to O(M*N) times EPS, EPS = ', EPS + NFAILQ_TOTAL = NFAILQ_TOTAL + NFAIL_SVDIFF + END IF + + IF ( NFAIL_F_QR == 0 ) THEN + WRITE(*,*) '>>>> F - Q*R test PASSED.' + ELSE + WRITE(*,*) 'F - Q*R test FAILED ', NFAIL_F_QR, ' time(s)' + WRITE(*,*) 'The largest relative residual was ', TMP_FQR + WRITE(*,*) 'It should be up to O(M*N) times EPS, EPS = ', EPS + NFAILQ_TOTAL = NFAILQ_TOTAL + NFAIL_F_QR + END IF + + IF ( NFAIL_REZQ == 0 ) THEN + WRITE(*,*) '>>>> Rezidual computation test PASSED.' + ELSE + WRITE(*,*) 'Rezidual computation test FAILED ', NFAIL_REZQ, 'time(s)' + WRITE(*,*) 'Max residual computing test adjusted error measure was ', TMP_REZQ + WRITE(*,*) 'It should be up to O(M*N) times EPS, EPS = ', EPS + NFAILQ_TOTAL = NFAILQ_TOTAL + NFAIL_REZQ + END IF + + IF ( NFAILQ_TOTAL == 0 ) THEN + WRITE(*,*) '>>>>>>> SGEDMDQ :: ALL TESTS PASSED.' + ELSE + WRITE(*,*) NFAILQ_TOTAL, 'FAILURES!' + WRITE(*,*) '>>>>>>> SGEDMDQ :: TESTS FAILED. CHECK THE IMPLEMENTATION.' + END IF + + END IF + + WRITE(*,*) + WRITE(*,*) 'Test completed.' + STOP + END diff --git a/lapack-netlib/TESTING/EIG/zchkdmd.f90 b/lapack-netlib/TESTING/EIG/zchkdmd.f90 new file mode 100644 index 000000000..873d956c4 --- /dev/null +++ b/lapack-netlib/TESTING/EIG/zchkdmd.f90 @@ -0,0 +1,745 @@ +! This is a test program for checking the implementations of +! the implementations of the following subroutines +! +! ZGEDMD, for computation of the +! Dynamic Mode Decomposition (DMD) +! ZGEDMDQ, for computation of a +! QR factorization based compressed DMD +! +! Developed and supported by: +! =========================== +! Developed and coded by Zlatko Drmac, Faculty of Science, +! University of Zagreb; drmac@math.hr +! In cooperation with +! AIMdyn Inc., Santa Barbara, CA. +! ======================================================== +! How to run the code (compiler, link info) +! ======================================================== +! Compile as FORTRAN 90 (or later) and link with BLAS and +! LAPACK libraries. +! NOTE: The code is developed and tested on top of the +! Intel MKL library (versions 2022.0.3 and 2022.2.0), +! using the Intel Fortran compiler. +! +! For developers of the C++ implementation +! ======================================================== +! See the LAPACK++ and Template Numerical Toolkit (TNT) +! +! Note on a development of the GPU HP implementation +! ======================================================== +! Work in progress. See CUDA, MAGMA, SLATE. +! NOTE: The four SVD subroutines used in this code are +! included as a part of R&D and for the completeness. +! This was also an opportunity to test those SVD codes. +! If the scaling option is used all four are essentially +! equally good. For implementations on HP platforms, +! one can use whichever SVD is available. +!............................................................ + +!............................................................ +!............................................................ +! + PROGRAM DMD_TEST + use iso_fortran_env, only: real64 + IMPLICIT NONE + integer, parameter :: WP = real64 + +!............................................................ + REAL(KIND=WP), PARAMETER :: ONE = 1.0_WP + REAL(KIND=WP), PARAMETER :: ZERO = 0.0_WP + + COMPLEX(KIND=WP), PARAMETER :: ZONE = ( 1.0_WP, 0.0_WP ) + COMPLEX(KIND=WP), PARAMETER :: ZZERO = ( 0.0_WP, 0.0_WP ) +!............................................................ + REAL(KIND=WP), ALLOCATABLE, DIMENSION(:) :: RES, & + RES1, RESEX, SINGVX, SINGVQX, WORK + INTEGER , ALLOCATABLE, DIMENSION(:) :: IWORK + REAL(KIND=WP) :: WDUMMY(2) + INTEGER :: IDUMMY(4), ISEED(4) + REAL(KIND=WP) :: ANORM, COND, CONDL, CONDR, EPS, & + TOL, TOL2, SVDIFF, TMP, TMP_AU, & + TMP_FQR, TMP_REZ, TMP_REZQ, TMP_ZXW, & + TMP_EX + +!............................................................ + COMPLEX(KIND=WP) :: ZMAX + INTEGER :: LZWORK + COMPLEX(KIND=WP), ALLOCATABLE, DIMENSION(:,:) :: ZA, ZAC, & + ZAU, ZF, ZF0, ZF1, ZS, ZW, & + ZX, ZX0, ZY, ZY0, ZY1, ZZ, ZZ1 + COMPLEX(KIND=WP), ALLOCATABLE, DIMENSION(:) :: ZDA, ZDR, & + ZDL, ZEIGS, ZEIGSA, ZWORK + COMPLEX(KIND=WP) :: ZDUMMY(22), ZDUM2X2(2,2) +!............................................................ + INTEGER :: K, KQ, LDF, LDS, LDA, LDAU, LDW, LDX, LDY, & + LDZ, LIWORK, LWORK, M, N, LLOOP, NRNK, NRNKsp + INTEGER :: i, iJOBREF, iJOBZ, iSCALE, INFO, j, & + NFAIL, NFAIL_AU, NFAIL_F_QR, NFAIL_REZ, & + NFAIL_REZQ, NFAIL_SVDIFF, NFAIL_TOTAL, NFAILQ_TOTAL, & + NFAIL_Z_XV, MODE, MODEL, MODER, WHTSVD, & + WHTSVDsp + INTEGER :: iNRNK, iWHTSVD, K_TRAJ, LWMINOPT + CHARACTER :: GRADE, JOBREF, JOBZ, PIVTNG, RSIGN, & + SCALE, RESIDS, WANTQ, WANTR + LOGICAL :: TEST_QRDMD + +!.....external subroutines (BLAS and LAPACK) + EXTERNAL DAXPY, DGEEV, DGEMM, DGEMV, DLACPY, DLASCL + EXTERNAL ZGEEV, ZGEMV, ZLASCL + EXTERNAL ZLARNV, ZLATMR + EXTERNAL ZAXPY, ZGEMM +!.....external subroutines DMD package, part 1 +! subroutines under test + EXTERNAL ZGEDMD, ZGEDMDQ +!.....external functions (BLAS and LAPACK) + EXTERNAL DLAMCH, DZNRM2 + REAL(KIND=WP) :: DLAMCH, DZNRM2 + REAL(KIND=WP) :: ZLANGE + EXTERNAL IZAMAX + INTEGER IZAMAX + EXTERNAL LSAME + LOGICAL LSAME + + INTRINSIC ABS, INT, MIN, MAX, SIGN +!............................................................ + + ! The test is always in pairs : ( ZGEDMD and ZGEDMDQ ) + ! because the test includes comparing the results (in pairs). +!..................................................................................... + TEST_QRDMD = .TRUE. ! This code by default performs tests on ZGEDMDQ + ! Since the QR factorizations based algorithm is designed for + ! single trajectory data, only single trajectory tests will + ! be performed with xGEDMDQ. + WANTQ = 'Q' + WANTR = 'R' +!................................................................................. + + EPS = DLAMCH( 'P' ) ! machine precision DP + + ! Global counters of failures of some particular tests + NFAIL = 0 + NFAIL_REZ = 0 + NFAIL_REZQ = 0 + NFAIL_Z_XV = 0 + NFAIL_F_QR = 0 + NFAIL_AU = 0 + NFAIL_SVDIFF = 0 + NFAIL_TOTAL = 0 + NFAILQ_TOTAL = 0 + + DO LLOOP = 1, 4 + + WRITE(*,*) 'L Loop Index = ', LLOOP + + ! Set the dimensions of the problem ... + WRITE(*,*) 'M = ' + READ(*,*) M + WRITE(*,*) M + ! ... and the number of snapshots. + WRITE(*,*) 'N = ' + READ(*,*) N + WRITE(*,*) N + + ! ... Test the dimensions + IF ( ( MIN(M,N) == 0 ) .OR. ( M < N ) ) THEN + WRITE(*,*) 'Bad dimensions. Required: M >= N > 0.' + STOP + END IF +!............. + ! The seed inside the LLOOP so that each pass can be reproduced easily. + ISEED(1) = 4 + ISEED(2) = 3 + ISEED(3) = 2 + ISEED(4) = 1 + + LDA = M + LDF = M + LDX = M + LDY = M + LDW = N + LDZ = M + LDAU = M + LDS = N + + TMP_ZXW = ZERO + TMP_AU = ZERO + TMP_REZ = ZERO + TMP_REZQ = ZERO + SVDIFF = ZERO + TMP_EX = ZERO + + ALLOCATE( ZA(LDA,M) ) + ALLOCATE( ZAC(LDA,M) ) + ALLOCATE( ZF(LDF,N+1) ) + ALLOCATE( ZF0(LDF,N+1) ) + ALLOCATE( ZF1(LDF,N+1) ) + ALLOCATE( ZX(LDX,N) ) + ALLOCATE( ZX0(LDX,N) ) + ALLOCATE( ZY(LDY,N+1) ) + ALLOCATE( ZY0(LDY,N+1) ) + ALLOCATE( ZY1(LDY,N+1) ) + ALLOCATE( ZAU(LDAU,N) ) + ALLOCATE( ZW(LDW,N) ) + ALLOCATE( ZS(LDS,N) ) + ALLOCATE( ZZ(LDZ,N) ) + ALLOCATE( ZZ1(LDZ,N) ) + ALLOCATE( RES(N) ) + ALLOCATE( RES1(N) ) + ALLOCATE( RESEX(N) ) + ALLOCATE( ZEIGS(N) ) + ALLOCATE( SINGVX(N) ) + ALLOCATE( SINGVQX(N) ) + + TOL = M*EPS + ! This mimics O(M*N)*EPS bound for accumulated roundoff error. + ! The factor 10 is somewhat arbitrary. + TOL2 = 10*M*N*EPS + +!............. + + DO K_TRAJ = 1, 2 + ! Number of intial conditions in the simulation/trajectories (1 or 2) + + COND = 1.0D4 + ZMAX = (1.0D1,1.0D1) + RSIGN = 'F' + GRADE = 'N' + MODEL = 6 + CONDL = 1.0D1 + MODER = 6 + CONDR = 1.0D1 + PIVTNG = 'N' + + ! Loop over all parameter MODE values for ZLATMR (+1,..,+6) + DO MODE = 1, 6 + + ALLOCATE( IWORK(2*M) ) + ALLOCATE( ZDA(M) ) + ALLOCATE( ZDL(M) ) + ALLOCATE( ZDR(M) ) + + CALL ZLATMR( M, M, 'N', ISEED, 'N', ZDA, MODE, COND, & + ZMAX, RSIGN, GRADE, ZDL, MODEL, CONDL, & + ZDR, MODER, CONDR, PIVTNG, IWORK, M, M, & + ZERO, -ONE, 'N', ZA, LDA, IWORK(M+1), INFO ) + DEALLOCATE( ZDR ) + DEALLOCATE( ZDL ) + DEALLOCATE( ZDA ) + DEALLOCATE( IWORK ) + + LZWORK = MAX(1,2*M) + ALLOCATE( ZEIGSA(M) ) + ALLOCATE( ZWORK(LZWORK) ) + ALLOCATE( WORK(2*M) ) + ZAC(1:M,1:M) = ZA(1:M,1:M) + CALL ZGEEV( 'N','N', M, ZAC, LDA, ZEIGSA, ZDUM2X2, 2, & + ZDUM2X2, 2, ZWORK, LZWORK, WORK, INFO ) ! LAPACK CALL + DEALLOCATE(WORK) + DEALLOCATE(ZWORK) + + TMP = ABS(ZEIGSA(IZAMAX(M, ZEIGSA, 1))) ! The spectral radius of ZA + ! Scale the matrix ZA to have unit spectral radius. + CALL ZLASCL( 'G',0, 0, TMP, ONE, M, M, & + ZA, LDA, INFO ) + CALL ZLASCL( 'G',0, 0, TMP, ONE, M, 1, & + ZEIGSA, M, INFO ) + ANORM = ZLANGE( 'F', M, M, ZA, LDA, WDUMMY ) + + IF ( K_TRAJ == 2 ) THEN + ! generate data as two trajectories + ! with two inital conditions + CALL ZLARNV(2, ISEED, M, ZF(1,1) ) + DO i = 1, N/2 + CALL ZGEMV( 'N', M, M, ZONE, ZA, LDA, ZF(1,i), 1, & + ZZERO, ZF(1,i+1), 1 ) + END DO + ZX0(1:M,1:N/2) = ZF(1:M,1:N/2) + ZY0(1:M,1:N/2) = ZF(1:M,2:N/2+1) + + CALL ZLARNV(2, ISEED, M, ZF(1,1) ) + DO i = 1, N-N/2 + CALL ZGEMV( 'N', M, M, ZONE, ZA, LDA, ZF(1,i), 1, & + ZZERO, ZF(1,i+1), 1 ) + END DO + ZX0(1:M,N/2+1:N) = ZF(1:M,1:N-N/2) + ZY0(1:M,N/2+1:N) = ZF(1:M,2:N-N/2+1) + ELSE + CALL ZLARNV(2, ISEED, M, ZF(1,1) ) + DO i = 1, N + CALL ZGEMV( 'N', M, M, ZONE, ZA, M, ZF(1,i), 1, & + ZZERO, ZF(1,i+1), 1 ) + END DO + ZF0(1:M,1:N+1) = ZF(1:M,1:N+1) + ZX0(1:M,1:N) = ZF0(1:M,1:N) + ZY0(1:M,1:N) = ZF0(1:M,2:N+1) + END IF + + DEALLOCATE( ZEIGSA ) +!........................................................................ + + DO iJOBZ = 1, 4 + + SELECT CASE ( iJOBZ ) + CASE(1) + JOBZ = 'V' + RESIDS = 'R' + CASE(2) + JOBZ = 'V' + RESIDS = 'N' + CASE(3) + JOBZ = 'F' + RESIDS = 'N' + CASE(4) + JOBZ = 'N' + RESIDS = 'N' + END SELECT + + DO iJOBREF = 1, 3 + + SELECT CASE ( iJOBREF ) + CASE(1) + JOBREF = 'R' + CASE(2) + JOBREF = 'E' + CASE(3) + JOBREF = 'N' + END SELECT + + DO iSCALE = 1, 4 + + SELECT CASE ( iSCALE ) + CASE(1) + SCALE = 'S' + CASE(2) + SCALE = 'C' + CASE(3) + SCALE = 'Y' + CASE(4) + SCALE = 'N' + END SELECT + + DO iNRNK = -1, -2, -1 + NRNK = iNRNK + NRNKsp = iNRNK + + DO iWHTSVD = 1, 3 + ! Check all four options to compute the POD basis + ! via the SVD. + WHTSVD = iWHTSVD + WHTSVDsp = iWHTSVD + + DO LWMINOPT = 1, 2 + ! Workspace query for the minimal (1) and for the optimal + ! (2) workspace lengths determined by workspace query. + + ! ZGEDMD is always tested and its results are also used for + ! comparisons with ZGEDMDQ. + + ZX(1:M,1:N) = ZX0(1:M,1:N) + ZY(1:M,1:N) = ZY0(1:M,1:N) + + CALL ZGEDMD( SCALE, JOBZ, RESIDS, JOBREF, WHTSVD, & + M, N, ZX, LDX, ZY, LDY, NRNK, TOL, & + K, ZEIGS, ZZ, LDZ, RES, ZAU, LDAU, & + ZW, LDW, ZS, LDS, ZDUMMY, -1, & + WDUMMY, -1, IDUMMY, -1, INFO ) + IF ( (INFO .EQ. 2) .OR. ( INFO .EQ. 3 ) & + .OR. ( INFO < 0 ) ) THEN + WRITE(*,*) 'Call to ZGEDMD workspace query failed. & + &Check the calling sequence and the code.' + WRITE(*,*) 'The error code is ', INFO + WRITE(*,*) 'The input parameters were ', & + SCALE, JOBZ, RESIDS, JOBREF, WHTSVD, & + M, N, LDX, LDY, NRNK, TOL, LDZ, LDAU, LDW, LDS + STOP + END IF + + LZWORK = INT(ZDUMMY(LWMINOPT)) + LWORK = INT(WDUMMY(1)) + LIWORK = IDUMMY(1) + + ALLOCATE(ZWORK(LZWORK)) + ALLOCATE( WORK(LWORK)) + ALLOCATE(IWORK(LIWORK)) + + CALL ZGEDMD( SCALE, JOBZ, RESIDS, JOBREF, WHTSVD, & + M, N, ZX, LDX, ZY, LDY, NRNK, TOL, & + K, ZEIGS, ZZ, LDZ, RES, ZAU, LDAU, & + ZW, LDW, ZS, LDS, ZWORK, LZWORK, & + WORK, LWORK, IWORK, LIWORK, INFO ) + + IF ( INFO /= 0 ) THEN + WRITE(*,*) 'Call to ZGEDMD failed. & + &Check the calling sequence and the code.' + WRITE(*,*) 'The error code is ', INFO + WRITE(*,*) 'The input parameters were ',& + SCALE, JOBZ, RESIDS, JOBREF, WHTSVD, & + M, N, LDX, LDY, NRNK, TOL + STOP + END IF + + SINGVX(1:N) = WORK(1:N) + + !...... ZGEDMD check point + IF ( LSAME(JOBZ,'V') ) THEN + ! Check that Z = X*W, on return from ZGEDMD + ! This checks that the returned eigenvectors in Z are + ! the product of the SVD'POD basis returned in X + ! and the eigenvectors of the rayleigh quotient + ! returned in W + CALL ZGEMM( 'N', 'N', M, K, K, ZONE, ZX, LDX, ZW, LDW, & + ZZERO, ZZ1, LDZ ) + TMP = ZERO + DO i = 1, K + CALL ZAXPY( M, -ZONE, ZZ(1,i), 1, ZZ1(1,i), 1) + TMP = MAX(TMP, DZNRM2( M, ZZ1(1,i), 1 ) ) + END DO + TMP_ZXW = MAX(TMP_ZXW, TMP ) + IF ( TMP_ZXW <= 10*M*EPS ) THEN + !WRITE(*,*) ' :) .... OK .........ZGEDMD PASSED.' + ELSE + NFAIL_Z_XV = NFAIL_Z_XV + 1 + WRITE(*,*) ':( .................ZGEDMD FAILED!', & + 'Check the code for implementation errors.' + WRITE(*,*) 'The input parameters were ',& + SCALE, JOBZ, RESIDS, JOBREF, WHTSVD, & + M, N, LDX, LDY, NRNK, TOL + END IF + END IF + + + !...... ZGEDMD check point + IF ( LSAME(JOBREF,'R') ) THEN + ! The matrix A*U is returned for computing refined Ritz vectors. + ! Check that A*U is computed correctly using the formula + ! A*U = Y * V * inv(SIGMA). This depends on the + ! accuracy in the computed singular values and vectors of X. + ! See the paper for an error analysis. + ! Note that the left singular vectors of the input matrix X + ! are returned in the array X. + CALL ZGEMM( 'N', 'N', M, K, M, ZONE, ZA, LDA, ZX, LDX, & + ZZERO, ZZ1, LDZ ) + TMP = ZERO + DO i = 1, K + CALL ZAXPY( M, -ZONE, ZAU(1,i), 1, ZZ1(1,i), 1) + TMP = MAX( TMP, DZNRM2( M, ZZ1(1,i),1 ) * & + SINGVX(K)/(ANORM*SINGVX(1)) ) + END DO + TMP_AU = MAX( TMP_AU, TMP ) + IF ( TMP <= TOL2 ) THEN + !WRITE(*,*) ':) .... OK .........ZGEDMD PASSED.' + ELSE + NFAIL_AU = NFAIL_AU + 1 + WRITE(*,*) ':( .................ZGEDMD FAILED!', & + 'Check the code for implementation errors.' + WRITE(*,*) 'The input parameters were ',& + SCALE, JOBZ, RESIDS, JOBREF, WHTSVD, & + M, N, LDX, LDY, NRNK, TOL + END IF + ELSEIF ( LSAME(JOBREF,'E') ) THEN + ! The unscaled vectors of the Exact DMD are computed. + ! This option is included for the sake of completeness, + ! for users who prefer the Exact DMD vectors. The + ! returned vectors are in the real form, in the same way + ! as the Ritz vectors. Here we just save the vectors + ! and test them separately using a Matlab script. + + + CALL ZGEMM( 'N', 'N', M, K, M, ZONE, ZA, LDA, ZAU, LDAU, ZZERO, ZY1, LDY ) + + DO i=1, K + ! have a real eigenvalue with real eigenvector + CALL ZAXPY( M, -ZEIGS(i), ZAU(1,i), 1, ZY1(1,i), 1 ) + RESEX(i) = DZNRM2( M, ZY1(1,i), 1) / DZNRM2(M,ZAU(1,i),1) + END DO + END IF + !...... ZGEDMD check point + + IF ( LSAME(RESIDS, 'R') ) THEN + ! Compare the residuals returned by ZGEDMD with the + ! explicitly computed residuals using the matrix A. + ! Compute explicitly Y1 = A*Z + CALL ZGEMM( 'N', 'N', M, K, M, ZONE, ZA, LDA, ZZ, LDZ, ZZERO, ZY1, LDY ) + ! ... and then A*Z(:,i) - LAMBDA(i)*Z(:,i), using the real forms + ! of the invariant subspaces that correspond to complex conjugate + ! pairs of eigencalues. (See the description of Z in ZGEDMD,) + + DO i=1, K + ! have a real eigenvalue with real eigenvector + CALL ZAXPY( M, -ZEIGS(i), ZZ(1,i), 1, ZY1(1,i), 1 ) + RES1(i) = DZNRM2( M, ZY1(1,i), 1) + END DO + TMP = ZERO + DO i = 1, K + TMP = MAX( TMP, ABS(RES(i) - RES1(i)) * & + SINGVX(K)/(ANORM*SINGVX(1)) ) + END DO + TMP_REZ = MAX( TMP_REZ, TMP ) + IF ( TMP <= TOL2 ) THEN + !WRITE(*,*) ':) .... OK ..........ZGEDMD PASSED.' + ELSE + NFAIL_REZ = NFAIL_REZ + 1 + WRITE(*,*) ':( ..................ZGEDMD FAILED!', & + 'Check the code for implementation errors.' + WRITE(*,*) 'The input parameters were ',& + SCALE, JOBZ, RESIDS, JOBREF, WHTSVD, & + M, N, LDX, LDY, NRNK, TOL + END IF + + + IF ( LSAME(JOBREF,'E') ) THEN + TMP = ZERO + DO i = 1, K + TMP = MAX( TMP, ABS(RES1(i) - RESEX(i))/(RES1(i)+RESEX(i)) ) + END DO + TMP_EX = MAX(TMP_EX,TMP) + END IF + + END IF + + DEALLOCATE(ZWORK) + DEALLOCATE(WORK) + DEALLOCATE(IWORK) + + IF ( TEST_QRDMD .AND. (K_TRAJ == 1) ) THEN + + ZF(1:M,1:N+1) = ZF0(1:M,1:N+1) + + CALL ZGEDMDQ( SCALE, JOBZ, RESIDS, WANTQ, WANTR, JOBREF, & + WHTSVD, M, N+1, ZF, LDF, ZX, LDX, ZY, LDY, & + NRNK, TOL, K, ZEIGS, ZZ, LDZ, RES, ZAU, & + LDAU, ZW, LDW, ZS, LDS, ZDUMMY, -1, & + WDUMMY, -1, IDUMMY, -1, INFO ) + + LZWORK = INT(ZDUMMY(LWMINOPT)) + ALLOCATE( ZWORK(LZWORK) ) + LIWORK = IDUMMY(1) + ALLOCATE(IWORK(LIWORK)) + LWORK = INT(WDUMMY(1)) + ALLOCATE(WORK(LWORK)) + + CALL ZGEDMDQ( SCALE, JOBZ, RESIDS, WANTQ, WANTR, JOBREF, & + WHTSVD, M, N+1, ZF, LDF, ZX, LDX, ZY, LDY, & + NRNK, TOL, KQ, ZEIGS, ZZ, LDZ, RES, ZAU, & + LDAU, ZW, LDW, ZS, LDS, ZWORK, LZWORK, & + WORK, LWORK, IWORK, LIWORK, INFO ) + + IF ( INFO /= 0 ) THEN + WRITE(*,*) 'Call to ZGEDMDQ failed. & + &Check the calling sequence and the code.' + WRITE(*,*) 'The error code is ', INFO + WRITE(*,*) 'The input parameters were ',& + SCALE, JOBZ, RESIDS, WANTQ, WANTR, WHTSVD, & + M, N, LDX, LDY, NRNK, TOL + STOP + END IF + SINGVQX(1:N) = WORK(1:N) + + !..... ZGEDMDQ check point + + IF ( 1 == 0 ) THEN + ! Comparison of ZGEDMD and ZGEDMDQ singular values disabled + TMP = ZERO + DO i = 1, MIN(K, KQ) + TMP = MAX(TMP, ABS(SINGVX(i)-SINGVQX(i)) / & + SINGVX(1) ) + END DO + SVDIFF = MAX( SVDIFF, TMP ) + IF ( TMP > M*N*EPS ) THEN + WRITE(*,*) 'FAILED! Something was wrong with the run.' + NFAIL_SVDIFF = NFAIL_SVDIFF + 1 + DO j =1, 3 + write(*,*) j, SINGVX(j), SINGVQX(j) + read(*,*) + END DO + + END IF + END IF + + !..... ZGEDMDQ check point + IF ( LSAME(WANTQ,'Q') .AND. LSAME(WANTR,'R') ) THEN + ! Check that the QR factors are computed and returned + ! as requested. The residual ||F-Q*R||_F / ||F||_F + ! is compared to M*N*EPS. + ZF1(1:M,1:N+1) = ZF0(1:M,1:N+1) + CALL ZGEMM( 'N', 'N', M, N+1, MIN(M,N+1), -ZONE, ZF, & + LDF, ZY, LDY, ZONE, ZF1, LDF ) + TMP_FQR = ZLANGE( 'F', M, N+1, ZF1, LDF, WORK ) / & + ZLANGE( 'F', M, N+1, ZF0, LDF, WORK ) + IF ( TMP_FQR > TOL2 ) THEN + WRITE(*,*) 'FAILED! Something was wrong with the run.' + NFAIL_F_QR = NFAIL_F_QR + 1 + ELSE + !WRITE(*,*) '........ PASSED.' + END IF + END IF + + !..... ZGEDMDQ check point + IF ( LSAME(RESIDS, 'R') ) THEN + ! Compare the residuals returned by ZGEDMDQ with the + ! explicitly computed residuals using the matrix A. + ! Compute explicitly Y1 = A*Z + CALL ZGEMM( 'N', 'N', M, KQ, M, ZONE, ZA, LDA, ZZ, LDZ, ZZERO, ZY1, LDY ) + ! ... and then A*Z(:,i) - LAMBDA(i)*Z(:,i), using the real forms + ! of the invariant subspaces that correspond to complex conjugate + ! pairs of eigencalues. (See the description of Z in ZGEDMDQ) + + DO i=1, KQ + ! have a real eigenvalue with real eigenvector + CALL ZAXPY( M, -ZEIGS(i), ZZ(1,i), 1, ZY1(1,i), 1 ) + ! Y(1:M,i) = Y(1:M,i) - REIG(i)*Z(1:M,i) + RES1(i) = DZNRM2( M, ZY1(1,i), 1) + END DO + TMP = ZERO + DO i = 1, KQ + TMP = MAX( TMP, ABS(RES(i) - RES1(i)) * & + SINGVQX(KQ)/(ANORM*SINGVQX(1)) ) + END DO + TMP_REZQ = MAX( TMP_REZQ, TMP ) + IF ( TMP <= TOL2 ) THEN + !WRITE(*,*) '.... OK ........ ZGEDMDQ PASSED.' + ELSE + NFAIL_REZQ = NFAIL_REZQ + 1 + WRITE(*,*) '................ ZGEDMDQ FAILED!', & + 'Check the code for implementation errors.' + STOP + END IF + + END IF + + DEALLOCATE( ZWORK ) + DEALLOCATE( WORK ) + DEALLOCATE( IWORK ) + + END IF ! ZGEDMDQ + +!....................................................................................................... + + END DO ! LWMINOPT + !write(*,*) 'LWMINOPT loop completed' + END DO ! iWHTSVD + !write(*,*) 'WHTSVD loop completed' + END DO ! iNRNK -2:-1 + !write(*,*) 'NRNK loop completed' + END DO ! iSCALE 1:4 + !write(*,*) 'SCALE loop completed' + END DO + !write(*,*) 'JOBREF loop completed' + END DO ! iJOBZ + !write(*,*) 'JOBZ loop completed' + + END DO ! MODE -6:6 + !write(*,*) 'MODE loop completed' + END DO ! 1 or 2 trajectories + !write(*,*) 'trajectories loop completed' + + DEALLOCATE( ZA ) + DEALLOCATE( ZAC ) + DEALLOCATE( ZZ ) + DEALLOCATE( ZF ) + DEALLOCATE( ZF0 ) + DEALLOCATE( ZF1 ) + DEALLOCATE( ZX ) + DEALLOCATE( ZX0 ) + DEALLOCATE( ZY ) + DEALLOCATE( ZY0 ) + DEALLOCATE( ZY1 ) + DEALLOCATE( ZAU ) + DEALLOCATE( ZW ) + DEALLOCATE( ZS ) + DEALLOCATE( ZZ1 ) + DEALLOCATE( RES ) + DEALLOCATE( RES1 ) + DEALLOCATE( RESEX ) + DEALLOCATE( ZEIGS ) + DEALLOCATE( SINGVX ) + DEALLOCATE( SINGVQX ) + + END DO ! LLOOP + + WRITE(*,*) '>>>>>>>>>>>>>>>>>>>>>>>>>>' + WRITE(*,*) ' Test summary for ZGEDMD :' + WRITE(*,*) '>>>>>>>>>>>>>>>>>>>>>>>>>>' + WRITE(*,*) + IF ( NFAIL_Z_XV == 0 ) THEN + WRITE(*,*) '>>>> Z - U*V test PASSED.' + ELSE + WRITE(*,*) 'Z - U*V test FAILED ', NFAIL_Z_XV, ' time(s)' + WRITE(*,*) 'Max error ||Z-U*V||_F was ', TMP_ZXW + NFAIL_TOTAL = NFAIL_TOTAL + NFAIL_Z_XV + END IF + IF ( NFAIL_AU == 0 ) THEN + WRITE(*,*) '>>>> A*U test PASSED. ' + ELSE + WRITE(*,*) 'A*U test FAILED ', NFAIL_AU, ' time(s)' + WRITE(*,*) 'Max A*U test adjusted error measure was ', TMP_AU + WRITE(*,*) 'It should be up to O(M*N) times EPS, EPS = ', EPS + NFAIL_TOTAL = NFAIL_TOTAL + NFAIL_AU + END IF + + IF ( NFAIL_REZ == 0 ) THEN + WRITE(*,*) '>>>> Rezidual computation test PASSED.' + ELSE + WRITE(*,*) 'Rezidual computation test FAILED ', NFAIL_REZ, 'time(s)' + WRITE(*,*) 'Max residual computing test adjusted error measure was ', TMP_REZ + WRITE(*,*) 'It should be up to O(M*N) times EPS, EPS = ', EPS + NFAIL_TOTAL = NFAIL_TOTAL + NFAIL_REZ + END IF + + IF ( NFAIL_TOTAL == 0 ) THEN + WRITE(*,*) '>>>> ZGEDMD :: ALL TESTS PASSED.' + ELSE + WRITE(*,*) NFAIL_TOTAL, 'FAILURES!' + WRITE(*,*) '>>>>>>>>>>>>>> ZGEDMD :: TESTS FAILED. CHECK THE IMPLEMENTATION.' + END IF + + IF ( TEST_QRDMD ) THEN + WRITE(*,*) + WRITE(*,*) '>>>>>>>>>>>>>>>>>>>>>>>>>>' + WRITE(*,*) ' Test summary for ZGEDMDQ :' + WRITE(*,*) '>>>>>>>>>>>>>>>>>>>>>>>>>>' + WRITE(*,*) + + IF ( NFAIL_SVDIFF == 0 ) THEN + WRITE(*,*) '>>>> ZGEDMD and ZGEDMDQ computed singular & + &values test PASSED.' + ELSE + WRITE(*,*) 'ZGEDMD and ZGEDMDQ discrepancies in & + &the singular values unacceptable ', & + NFAIL_SVDIFF, ' times. Test FAILED.' + WRITE(*,*) 'The maximal discrepancy in the singular values (relative to the norm) was ', SVDIFF + WRITE(*,*) 'It should be up to O(M*N) times EPS, EPS = ', EPS + NFAILQ_TOTAL = NFAILQ_TOTAL + NFAIL_SVDIFF + END IF + + IF ( NFAIL_F_QR == 0 ) THEN + WRITE(*,*) '>>>> F - Q*R test PASSED.' + ELSE + WRITE(*,*) 'F - Q*R test FAILED ', NFAIL_F_QR, ' time(s)' + WRITE(*,*) 'The largest relative residual was ', TMP_FQR + WRITE(*,*) 'It should be up to O(M*N) times EPS, EPS = ', EPS + NFAILQ_TOTAL = NFAILQ_TOTAL + NFAIL_F_QR + END IF + + IF ( NFAIL_REZQ == 0 ) THEN + WRITE(*,*) '>>>> Rezidual computation test PASSED.' + ELSE + WRITE(*,*) 'Rezidual computation test FAILED ', NFAIL_REZQ, 'time(s)' + WRITE(*,*) 'Max residual computing test adjusted error measure was ', TMP_REZQ + WRITE(*,*) 'It should be up to O(M*N) times EPS, EPS = ', EPS + NFAILQ_TOTAL = NFAILQ_TOTAL + NFAIL_REZQ + END IF + + IF ( NFAILQ_TOTAL == 0 ) THEN + WRITE(*,*) '>>>>>>> ZGEDMDQ :: ALL TESTS PASSED.' + ELSE + WRITE(*,*) NFAILQ_TOTAL, 'FAILURES!' + WRITE(*,*) '>>>>>>> ZGEDMDQ :: TESTS FAILED. CHECK THE IMPLEMENTATION.' + END IF + + END IF + + WRITE(*,*) + WRITE(*,*) 'Test completed.' + STOP + END From fa03e5497a11e4861cf8908aeb09249b39473c9c Mon Sep 17 00:00:00 2001 From: Martin Kroeker Date: Tue, 5 Dec 2023 15:43:28 +0100 Subject: [PATCH 36/60] Add tests for the DMD functions (Reference-LAPACK PR 736) --- lapack-netlib/TESTING/Makefile | 43 ++++++++++++++++++++++++++++++---- lapack-netlib/TESTING/cdmd.in | 11 +++++++++ lapack-netlib/TESTING/ddmd.in | 11 +++++++++ lapack-netlib/TESTING/sdmd.in | 11 +++++++++ lapack-netlib/TESTING/zdmd.in | 11 +++++++++ 5 files changed, 83 insertions(+), 4 deletions(-) create mode 100644 lapack-netlib/TESTING/cdmd.in create mode 100644 lapack-netlib/TESTING/ddmd.in create mode 100644 lapack-netlib/TESTING/sdmd.in create mode 100644 lapack-netlib/TESTING/zdmd.in diff --git a/lapack-netlib/TESTING/Makefile b/lapack-netlib/TESTING/Makefile index bdea2bfaa..3963260ac 100644 --- a/lapack-netlib/TESTING/Makefile +++ b/lapack-netlib/TESTING/Makefile @@ -61,6 +61,8 @@ SEIGTST= snep.out \ scsd.out \ slse.out +SDMDEIGTST= sdmd.out + CEIGTST= cnep.out \ csep.out \ cse2.out \ @@ -82,6 +84,8 @@ CEIGTST= cnep.out \ ccsd.out \ clse.out +CDMDEIGTST= cdmd.out + DEIGTST= dnep.out \ dsep.out \ dse2.out \ @@ -103,6 +107,8 @@ DEIGTST= dnep.out \ dcsd.out \ dlse.out +DDMDEIGTST= ddmd.out + ZEIGTST= znep.out \ zsep.out \ zse2.out \ @@ -124,6 +130,7 @@ ZEIGTST= znep.out \ zcsd.out \ zlse.out +ZDMDEIGTST= zdmd.out SLINTST= stest.out @@ -142,10 +149,10 @@ ZLINTST= ztest.out ZLINTSTPROTO= zctest.out ztest_rfp.out .PHONY: single complex double complex16 -single: $(SLINTST) $(SEIGTST) -complex: $(CLINTST) $(CEIGTST) -double: $(DLINTST) $(DEIGTST) -complex16: $(ZLINTST) $(ZEIGTST) +single: $(SLINTST) $(SEIGTST) $(SDMDEIGTST) +complex: $(CLINTST) $(CEIGTST) $(CDMDEIGTST) +double: $(DLINTST) $(DEIGTST) $(DDMDEIGTST) +complex16: $(ZLINTST) $(ZEIGTST) $(ZDMDEIGTST) .PHONY: singleproto complexproto doubleproto complex16proto singleproto: $(SLINTSTPROTO) @@ -297,6 +304,10 @@ scsd.out: csd.in EIG/xeigtsts slse.out: lse.in EIG/xeigtsts @echo LSE: Testing Constrained Linear Least Squares routines ./EIG/xeigtsts < lse.in > $@ 2>&1 + +sdmd.out: sdmd.in EIG/xdmdeigtsts + @echo DMD: Testing Dynamic Mode Decomposition routines + ./EIG/xdmdeigtsts < sdmd.in > $@ 2>&1 # # ======== COMPLEX EIG TESTS =========================== @@ -379,6 +390,10 @@ ccsd.out: csd.in EIG/xeigtstc clse.out: lse.in EIG/xeigtstc @echo LSE: Testing Constrained Linear Least Squares routines ./EIG/xeigtstc < lse.in > $@ 2>&1 + +cdmd.out: cdmd.in EIG/xdmdeigtstc + @echo DMD: Testing Dynamic Mode Decomposition routines + ./EIG/xdmdeigtstc < cdmd.in > $@ 2>&1 # # ======== DOUBLE EIG TESTS =========================== @@ -461,6 +476,10 @@ dcsd.out: csd.in EIG/xeigtstd dlse.out: lse.in EIG/xeigtstd @echo LSE: Testing Constrained Linear Least Squares routines ./EIG/xeigtstd < lse.in > $@ 2>&1 + +ddmd.out: ddmd.in EIG/xdmdeigtstd + @echo DMD: Testing Dynamic Mode Decomposition routines + ./EIG/xdmdeigtstd < ddmd.in > $@ 2>&1 # # ======== COMPLEX16 EIG TESTS =========================== @@ -543,6 +562,10 @@ zcsd.out: csd.in EIG/xeigtstz zlse.out: lse.in EIG/xeigtstz @echo LSE: Testing Constrained Linear Least Squares routines ./EIG/xeigtstz < lse.in > $@ 2>&1 + +zdmd.out: zdmd.in EIG/xdmdeigtstz + @echo DMD: Testing Dynamic Mode Decomposition routines + ./EIG/xdmdeigtstz < zdmd.in > $@ 2>&1 # ============================================================================== LIN/xlintsts: $(FRCLIN) $(FRC) @@ -578,15 +601,27 @@ LIN/xlintstzc: $(FRCLIN) $(FRC) EIG/xeigtsts: $(FRCEIG) $(FRC) $(MAKE) -C EIG xeigtsts +EIG/xdmdeigtsts: $(FRCEIG) $(FRC) + $(MAKE) -C EIG xdmdeigtsts + EIG/xeigtstc: $(FRCEIG) $(FRC) $(MAKE) -C EIG xeigtstc +EIG/xdmdeigtstc: $(FRCEIG) $(FRC) + $(MAKE) -C EIG xdmdeigtstc + EIG/xeigtstd: $(FRCEIG) $(FRC) $(MAKE) -C EIG xeigtstd +EIG/xdmdeigtstd: $(FRCEIG) $(FRC) + $(MAKE) -C EIG xdmdeigtstd + EIG/xeigtstz: $(FRCEIG) $(FRC) $(MAKE) -C EIG xeigtstz +EIG/xdmdeigtstz: $(FRCEIG) $(FRC) + $(MAKE) -C EIG xdmdeigtstz + .PHONY: clean cleantest clean: cleantest cleantest: diff --git a/lapack-netlib/TESTING/cdmd.in b/lapack-netlib/TESTING/cdmd.in new file mode 100644 index 000000000..42d046e01 --- /dev/null +++ b/lapack-netlib/TESTING/cdmd.in @@ -0,0 +1,11 @@ +10 +5 + +20 +10 + +30 +11 + +50 +20 diff --git a/lapack-netlib/TESTING/ddmd.in b/lapack-netlib/TESTING/ddmd.in new file mode 100644 index 000000000..42d046e01 --- /dev/null +++ b/lapack-netlib/TESTING/ddmd.in @@ -0,0 +1,11 @@ +10 +5 + +20 +10 + +30 +11 + +50 +20 diff --git a/lapack-netlib/TESTING/sdmd.in b/lapack-netlib/TESTING/sdmd.in new file mode 100644 index 000000000..42d046e01 --- /dev/null +++ b/lapack-netlib/TESTING/sdmd.in @@ -0,0 +1,11 @@ +10 +5 + +20 +10 + +30 +11 + +50 +20 diff --git a/lapack-netlib/TESTING/zdmd.in b/lapack-netlib/TESTING/zdmd.in new file mode 100644 index 000000000..42d046e01 --- /dev/null +++ b/lapack-netlib/TESTING/zdmd.in @@ -0,0 +1,11 @@ +10 +5 + +20 +10 + +30 +11 + +50 +20 From c5fa318addf536754df6e1c02d3a3cfb9e3becb9 Mon Sep 17 00:00:00 2001 From: Martin Kroeker Date: Tue, 5 Dec 2023 15:45:59 +0100 Subject: [PATCH 37/60] Add tests for DMD (Reference-LAPACK PR 736) --- lapack-netlib/lapack_testing.py | 85 +++++++++++++++++---------------- 1 file changed, 43 insertions(+), 42 deletions(-) diff --git a/lapack-netlib/lapack_testing.py b/lapack-netlib/lapack_testing.py index 5582744a0..ae59926b8 100755 --- a/lapack-netlib/lapack_testing.py +++ b/lapack-netlib/lapack_testing.py @@ -1,31 +1,29 @@ -#! /usr/bin/env python -# -*- coding: utf-8 -*- +#!/usr/bin/env python3 ############################################################################### # lapack_testing.py ############################################################################### -from __future__ import print_function from subprocess import Popen, STDOUT, PIPE import os, sys, math import getopt # Arguments try: opts, args = getopt.getopt(sys.argv[1:], "hd:b:srep:t:n", - ["help", "dir", "bin", "short", "run", "error","prec=","test=","number"]) + ["help", "dir=", "bin=", "short", "run", "error","prec=","test=","number"]) except getopt.error as msg: print(msg) print("for help use --help") sys.exit(2) -short_summary=0 -with_file=1 -just_errors = 0 +short_summary = False +with_file = True +just_errors = False prec='x' test='all' -only_numbers=0 +only_numbers = False test_dir='TESTING' bin_dir='bin/Release' @@ -34,10 +32,9 @@ for o, a in opts: print(sys.argv[0]+" [-h|--help] [-d dir |--dir dir] [-s |--short] [-r |--run] [-e |--error] [-p p |--prec p] [-t test |--test test] [-n | --number]") print(" - h is to print this message") print(" - r is to use to run the LAPACK tests then analyse the output (.out files). By default, the script will not run all the LAPACK tests") - print(" - d [dir] is to indicate where is the LAPACK testing directory (.out files). By default, the script will use .") - print(" - b [bin] is to indicate where is the LAPACK binary files are located. By default, the script will use .") + print(" - d [dir] indicates the location of the LAPACK testing directory (.out files). By default, the script will use {:s}.".format(test_dir)) + print(" - b [bin] indicates the location of the LAPACK binary files. By default, the script will use {:s}.".format(bin_dir)) print(" LEVEL OF OUTPUT") - print(" - x is to print a detailed summary") print(" - e is to print only the error summary") print(" - s is to print a short summary") print(" - n is to print the numbers of failing tests (turn on summary mode)") @@ -63,15 +60,14 @@ for o, a in opts: print(" Will return the numbers of failed tests in REAL precision by running the LAPACK Tests then analyzing the output") print(" ./lapack_testing.py -n -p s -t eig ") print(" Will return the numbers of failed tests in REAL precision by analyzing only the LAPACK output of EIGEN testings") - print("Written by Julie Langou (June 2011) ") sys.exit(0) else: if o in ("-s", "--short"): - short_summary = 1 + short_summary = True if o in ("-r", "--run"): - with_file = 0 + with_file = False if o in ("-e", "--error"): - just_errors = 1 + just_errors = True if o in ( '-p', '--prec' ): prec = a if o in ( '-b', '--bin' ): @@ -81,12 +77,12 @@ for o, a in opts: if o in ( '-t', '--test' ): test = a if o in ( '-n', '--number' ): - only_numbers = 1 - short_summary = 1 + only_numbers = True + short_summary = True # process options -abs_bin_dir=os.path.normpath(os.path.join(os.getcwd(),bin_dir)) +abs_bin_dir=os.path.abspath(bin_dir) os.chdir(test_dir) @@ -108,7 +104,7 @@ def run_summary_test( f, cmdline, short_summary): nb_test_illegal=0 nb_test_info=0 - if (with_file): + if with_file: if not os.path.exists(cmdline): error_message=cmdline+" file not found" r=1 @@ -145,16 +141,16 @@ def run_summary_test( f, cmdline, short_summary): whereisrun=words_in_line.index("run)") nb_test_run+=int(words_in_line[whereisrun-2]) if (line.find("out of")!=-1): - if (short_summary==0): print(line, end=' ') + if not short_summary: print(line, end=' ') whereisout= words_in_line.index("out") nb_test_fail+=int(words_in_line[whereisout-1]) if ((line.find("illegal")!=-1) or (line.find("Illegal")!=-1)): - if (short_summary==0):print(line, end=' ') + if not short_summary: print(line, end=' ') nb_test_illegal+=1 if (line.find(" INFO")!=-1): - if (short_summary==0):print(line, end=' ') + if not short_summary: print(line, end=' ') nb_test_info+=1 - if (with_file==1): + if with_file: pipe.close() f.flush(); @@ -169,7 +165,7 @@ try: except IOError: f = sys.stdout -if (short_summary==0): +if not short_summary: print(" ") print("---------------- Testing LAPACK Routines ----------------") print(" ") @@ -203,6 +199,8 @@ elif test=='mixed': range_prec=[1,3] elif test=='rfp': range_test=[18] +elif test=='dmd': + range_test=[20] elif test=='eig': range_test=list(range(16)) else: @@ -219,7 +217,7 @@ for dtype in range_prec: letter = dtypes[0][dtype] name = dtypes[1][dtype] - if (short_summary==0): + if not short_summary: print(" ") print("------------------------- %s ------------------------" % name) print(" ") @@ -231,19 +229,19 @@ for dtype in range_prec: letter+"gd",letter+"sb",letter+"sg", letter+"bb","glm","gqr", "gsv","csd","lse", - letter+"test", letter+dtypes[0][dtype-1]+"test",letter+"test_rfp"), + letter+"test", letter+dtypes[0][dtype-1]+"test",letter+"test_rfp",letter+"dmd"), ("Nonsymmetric-Eigenvalue-Problem", "Symmetric-Eigenvalue-Problem", "Symmetric-Eigenvalue-Problem-2-stage", "Singular-Value-Decomposition", "Eigen-Condition","Nonsymmetric-Eigenvalue","Nonsymmetric-Generalized-Eigenvalue-Problem", "Nonsymmetric-Generalized-Eigenvalue-Problem-driver", "Symmetric-Eigenvalue-Problem", "Symmetric-Eigenvalue-Generalized-Problem", "Banded-Singular-Value-Decomposition-routines", "Generalized-Linear-Regression-Model-routines", "Generalized-QR-and-RQ-factorization-routines", "Generalized-Singular-Value-Decomposition-routines", "CS-Decomposition-routines", "Constrained-Linear-Least-Squares-routines", - "Linear-Equation-routines", "Mixed-Precision-linear-equation-routines","RFP-linear-equation-routines"), + "Linear-Equation-routines", "Mixed-Precision-linear-equation-routines","RFP-linear-equation-routines","Dynamic-Mode-Decomposition"), (letter+"nep", letter+"sep", letter+"se2", letter+"svd", letter+"ec",letter+"ed",letter+"gg", letter+"gd",letter+"sb",letter+"sg", letter+"bb",letter+"glm",letter+"gqr", letter+"gsv",letter+"csd",letter+"lse", - letter+"test", letter+dtypes[0][dtype-1]+"test",letter+"test_rfp"), + letter+"test", letter+dtypes[0][dtype-1]+"test",letter+"test_rfp",letter+"dmd"), ) @@ -252,22 +250,25 @@ for dtype in range_prec: # NEED TO SKIP SOME PRECISION (namely s and c) FOR PROTO MIXED PRECISION TESTING if dtest==17 and (letter=="s" or letter=="c"): continue - if (with_file==1): + if with_file: cmdbase=dtests[2][dtest]+".out" else: if dtest==16: # LIN TESTS - cmdbase="LIN/xlintst"+letter+" < "+dtests[0][dtest]+".in > "+dtests[2][dtest]+".out" + cmdbase="xlintst"+letter+" < "+dtests[0][dtest]+".in > "+dtests[2][dtest]+".out" elif dtest==17: # PROTO LIN TESTS - cmdbase="LIN/xlintst"+letter+dtypes[0][dtype-1]+" < "+dtests[0][dtest]+".in > "+dtests[2][dtest]+".out" + cmdbase="xlintst"+letter+dtypes[0][dtype-1]+" < "+dtests[0][dtest]+".in > "+dtests[2][dtest]+".out" elif dtest==18: # PROTO LIN TESTS - cmdbase="LIN/xlintstrf"+letter+" < "+dtests[0][dtest]+".in > "+dtests[2][dtest]+".out" + cmdbase="xlintstrf"+letter+" < "+dtests[0][dtest]+".in > "+dtests[2][dtest]+".out" + elif dtest==20: + # DMD EIG TESTS + cmdbase="xdmdeigtst"+letter+" < "+dtests[0][dtest]+".in > "+dtests[2][dtest]+".out" else: # EIG TESTS - cmdbase="EIG/xeigtst"+letter+" < "+dtests[0][dtest]+".in > "+dtests[2][dtest]+".out" - if (not just_errors and not short_summary): + cmdbase="xeigtst"+letter+" < "+dtests[0][dtest]+".in > "+dtests[2][dtest]+".out" + if not just_errors and not short_summary: print("Testing "+name+" "+dtests[1][dtest]+"-"+cmdbase, end=' ') # Run the process: either to read the file or run the LAPACK testing nb_test = run_summary_test(f, cmdbase, short_summary) @@ -277,19 +278,19 @@ for dtype in range_prec: list_results[3][dtype]+=nb_test[3] got_error=nb_test[1]+nb_test[2]+nb_test[3] - if (not short_summary): - if (nb_test[0]>0 and just_errors==0): + if not short_summary: + if nb_test[0] > 0 and not just_errors: print("passed: "+str(nb_test[0])) - if (nb_test[1]>0): + if nb_test[1] > 0: print("failing to pass the threshold: "+str(nb_test[1])) - if (nb_test[2]>0): + if nb_test[2] > 0: print("Illegal Error: "+str(nb_test[2])) - if (nb_test[3]>0): + if nb_test[3] > 0: print("Info Error: "+str(nb_test[3])) - if (got_error>0 and just_errors==1): + if got_error > 0 and just_errors: print("ERROR IS LOCATED IN "+name+" "+dtests[1][dtest]+" [ "+cmdbase+" ]") print("") - if (just_errors==0): + if not just_errors: print("") # elif (got_error>0): # print dtests[2][dtest]+".out \t"+str(nb_test[1])+"\t"+str(nb_test[2])+"\t"+str(nb_test[3]) @@ -307,7 +308,7 @@ for dtype in range_prec: list_results[2][4]+=list_results[2][dtype] list_results[3][4]+=list_results[3][dtype] -if only_numbers==1: +if only_numbers: print(str(list_results[1][4])+"\n"+str(list_results[2][4]+list_results[3][4])) else: print(summary) From 226a14c5499e46d65cfd42b7e3b04fdca0844244 Mon Sep 17 00:00:00 2001 From: Martin Kroeker Date: Tue, 5 Dec 2023 15:50:06 +0100 Subject: [PATCH 38/60] Restore library path adjustments --- lapack-netlib/TESTING/EIG/Makefile | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/lapack-netlib/TESTING/EIG/Makefile b/lapack-netlib/TESTING/EIG/Makefile index 5de315b6e..4e7cf4629 100644 --- a/lapack-netlib/TESTING/EIG/Makefile +++ b/lapack-netlib/TESTING/EIG/Makefile @@ -135,28 +135,28 @@ complex: xeigtstc xdmdeigtstc double: xeigtstd xdmdeigtstd complex16: xeigtstz xdmdeigtstz -xdmdeigtsts: $(SDMDEIGTST) $(TMGLIB) $(LAPACKLIB) $(BLASLIB) +xdmdeigtsts: $(SDMDEIGTST) $(TMGLIB) ../$(LAPACKLIB) $(BLASLIB) $(FC) $(FFLAGS) $(LDFLAGS) -o $@ $^ -xdmdeigtstc: $(CDMDEIGTST) $(TMGLIB) $(LAPACKLIB) $(BLASLIB) +xdmdeigtstc: $(CDMDEIGTST) $(TMGLIB) ../$(LAPACKLIB) $(BLASLIB) $(FC) $(FFLAGS) $(LDFLAGS) -o $@ $^ -xdmdeigtstd: $(DDMDEIGTST) $(TMGLIB) $(LAPACKLIB) $(BLASLIB) +xdmdeigtstd: $(DDMDEIGTST) $(TMGLIB) ../$(LAPACKLIB) $(BLASLIB) $(FC) $(FFLAGS) $(LDFLAGS) -o $@ $^ -xdmdeigtstz: $(ZDMDEIGTST) $(TMGLIB) $(LAPACKLIB) $(BLASLIB) +xdmdeigtstz: $(ZDMDEIGTST) $(TMGLIB) ../$(LAPACKLIB) $(BLASLIB) $(FC) $(FFLAGS) $(LDFLAGS) -o $@ $^ -xeigtsts: $(SEIGTST) $(SCIGTST) $(AEIGTST) $(TMGLIB) $(LAPACKLIB) $(BLASLIB) +xeigtsts: $(SEIGTST) $(SCIGTST) $(AEIGTST) $(TMGLIB) ../$(LAPACKLIB) $(BLASLIB) $(FC) $(FFLAGS) $(LDFLAGS) -o $@ $^ -xeigtstc: $(CEIGTST) $(SCIGTST) $(AEIGTST) $(TMGLIB) $(LAPACKLIB) $(BLASLIB) +xeigtstc: $(CEIGTST) $(SCIGTST) $(AEIGTST) $(TMGLIB) ../$(LAPACKLIB) $(BLASLIB) $(FC) $(FFLAGS) $(LDFLAGS) -o $@ $^ -xeigtstd: $(DEIGTST) $(DZIGTST) $(AEIGTST) $(TMGLIB) $(LAPACKLIB) $(BLASLIB) +xeigtstd: $(DEIGTST) $(DZIGTST) $(AEIGTST) $(TMGLIB) ../$(LAPACKLIB) $(BLASLIB) $(FC) $(FFLAGS) $(LDFLAGS) -o $@ $^ -xeigtstz: $(ZEIGTST) $(DZIGTST) $(AEIGTST) $(TMGLIB) $(LAPACKLIB) $(BLASLIB) +xeigtstz: $(ZEIGTST) $(DZIGTST) $(AEIGTST) $(TMGLIB) ../$(LAPACKLIB) $(BLASLIB) $(FC) $(FFLAGS) $(LDFLAGS) -o $@ $^ $(SDMDEIGTST): $(FRC) From effb7af2a27f4f346f204223ce2372ba462412da Mon Sep 17 00:00:00 2001 From: Martin Kroeker Date: Tue, 5 Dec 2023 17:55:38 +0100 Subject: [PATCH 39/60] Fix memory leak (Reference-LAPACK PR 953) --- lapack-netlib/TESTING/LIN/cchkaa.F | 2 ++ lapack-netlib/TESTING/LIN/dchkaa.F | 2 ++ lapack-netlib/TESTING/LIN/schkaa.F | 2 ++ lapack-netlib/TESTING/LIN/zchkaa.F | 2 ++ 4 files changed, 8 insertions(+) diff --git a/lapack-netlib/TESTING/LIN/cchkaa.F b/lapack-netlib/TESTING/LIN/cchkaa.F index 474454a51..57d95c741 100644 --- a/lapack-netlib/TESTING/LIN/cchkaa.F +++ b/lapack-netlib/TESTING/LIN/cchkaa.F @@ -1232,6 +1232,8 @@ * DEALLOCATE (A, STAT = AllocateStatus) DEALLOCATE (B, STAT = AllocateStatus) + DEALLOCATE (E, STAT = AllocateStatus) + DEALLOCATE (S, STAT = AllocateStatus) DEALLOCATE (WORK, STAT = AllocateStatus) DEALLOCATE (RWORK, STAT = AllocateStatus) * diff --git a/lapack-netlib/TESTING/LIN/dchkaa.F b/lapack-netlib/TESTING/LIN/dchkaa.F index 74077eb94..6582cac13 100644 --- a/lapack-netlib/TESTING/LIN/dchkaa.F +++ b/lapack-netlib/TESTING/LIN/dchkaa.F @@ -1076,6 +1076,8 @@ * DEALLOCATE (A, STAT = AllocateStatus) DEALLOCATE (B, STAT = AllocateStatus) + DEALLOCATE (E, STAT = AllocateStatus) + DEALLOCATE (S, STAT = AllocateStatus) DEALLOCATE (WORK, STAT = AllocateStatus) DEALLOCATE (RWORK, STAT = AllocateStatus) * diff --git a/lapack-netlib/TESTING/LIN/schkaa.F b/lapack-netlib/TESTING/LIN/schkaa.F index 2b9f2ea45..036b13924 100644 --- a/lapack-netlib/TESTING/LIN/schkaa.F +++ b/lapack-netlib/TESTING/LIN/schkaa.F @@ -1070,6 +1070,8 @@ * DEALLOCATE (A, STAT = AllocateStatus) DEALLOCATE (B, STAT = AllocateStatus) + DEALLOCATE (E, STAT = AllocateStatus) + DEALLOCATE (S, STAT = AllocateStatus) DEALLOCATE (WORK, STAT = AllocateStatus) DEALLOCATE (RWORK, STAT = AllocateStatus) * diff --git a/lapack-netlib/TESTING/LIN/zchkaa.F b/lapack-netlib/TESTING/LIN/zchkaa.F index 57d71833f..f1020f2d8 100644 --- a/lapack-netlib/TESTING/LIN/zchkaa.F +++ b/lapack-netlib/TESTING/LIN/zchkaa.F @@ -1268,6 +1268,8 @@ * DEALLOCATE (A, STAT = AllocateStatus) DEALLOCATE (B, STAT = AllocateStatus) + DEALLOCATE (E, STAT = AllocateStatus) + DEALLOCATE (S, STAT = AllocateStatus) DEALLOCATE (RWORK, STAT = AllocateStatus) DEALLOCATE (WORK, STAT = AllocateStatus) * From 589f2b6466d7439220a72a99f5b385239bd37043 Mon Sep 17 00:00:00 2001 From: Martin Kroeker Date: Tue, 5 Dec 2023 20:10:20 +0100 Subject: [PATCH 40/60] Fix search phrase used to count successful tests (Reference-LAPACK PR 954) --- lapack-netlib/lapack_testing.py | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lapack-netlib/lapack_testing.py b/lapack-netlib/lapack_testing.py index ae59926b8..96fbeb2a6 100755 --- a/lapack-netlib/lapack_testing.py +++ b/lapack-netlib/lapack_testing.py @@ -136,7 +136,7 @@ def run_summary_test( f, cmdline, short_summary): for line in pipe.readlines(): f.write(str(line)) words_in_line=line.split() - if (line.find("run")!=-1): + if (line.find("run)")!=-1): # print line whereisrun=words_in_line.index("run)") nb_test_run+=int(words_in_line[whereisrun-2]) From 5f51811728645baae32ad54f7b34a00259e6e8e8 Mon Sep 17 00:00:00 2001 From: Mark Seminatore Date: Tue, 5 Dec 2023 22:43:36 -0800 Subject: [PATCH 41/60] try at new threading model --- CONTRIBUTORS.md | 3 + common_thread.h | 5 +- driver/others/blas_server_win32.c | 139 ++++++++++++++++-------------- 3 files changed, 79 insertions(+), 68 deletions(-) diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index 71df13634..493747052 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -216,3 +216,6 @@ In chronological order: * Pablo Romero * [2022-08] Fix building from sources for QNX + +* Mark Seminatore + * [2023-11-09] Improve Windows threading performance scaling \ No newline at end of file diff --git a/common_thread.h b/common_thread.h index 6e18d2a8e..9e7dae74a 100644 --- a/common_thread.h +++ b/common_thread.h @@ -111,8 +111,9 @@ typedef struct blas_queue { struct blas_queue *next; #if defined( __WIN32__) || defined(__CYGWIN32__) || defined(_WIN32) || defined(__CYGWIN__) - CRITICAL_SECTION lock; - HANDLE finish; + // CRITICAL_SECTION lock; + // HANDLE finish; + volatile int finished; #else pthread_mutex_t lock; pthread_cond_t finished; diff --git a/driver/others/blas_server_win32.c b/driver/others/blas_server_win32.c index 5bdfc1276..464e3fa03 100644 --- a/driver/others/blas_server_win32.c +++ b/driver/others/blas_server_win32.c @@ -51,15 +51,19 @@ /* This is a thread implementation for Win32 lazy implementation */ /* Thread server common information */ -typedef struct{ - CRITICAL_SECTION lock; - HANDLE filled; - HANDLE killed; - - blas_queue_t *queue; /* Parameter Pointer */ - int shutdown; /* server shutdown flag */ - -} blas_pool_t; +//typedef struct{ +// CRITICAL_SECTION lock; +// HANDLE filled; +// HANDLE killed; +// +// blas_queue_t *queue; /* Parameter Pointer */ +// int shutdown; /* server shutdown flag */ +// +//} blas_pool_t; + +static blas_queue_t *work_queue = NULL; +static HANDLE kickoff_event = NULL; +static CRITICAL_SECTION queue_lock; /* We need this global for checking if initialization is finished. */ int blas_server_avail = 0; @@ -67,7 +71,7 @@ int blas_server_avail = 0; /* Local Variables */ static BLASULONG server_lock = 0; -static blas_pool_t pool; +//static blas_pool_t pool; static HANDLE blas_threads [MAX_CPU_NUMBER]; static DWORD blas_threads_id[MAX_CPU_NUMBER]; @@ -209,7 +213,7 @@ static DWORD WINAPI blas_thread_server(void *arg){ void *buffer, *sa, *sb; blas_queue_t *queue; DWORD action; - HANDLE handles[] = {pool.filled, pool.killed}; + //HANDLE handles[] = {pool.filled, pool.killed}; /* Each server needs each buffer */ buffer = blas_memory_alloc(2); @@ -225,29 +229,38 @@ static DWORD WINAPI blas_thread_server(void *arg){ #ifdef SMP_DEBUG fprintf(STDERR, "Server[%2ld] Waiting for Queue.\n", cpu); #endif - - do { - action = WaitForMultipleObjects(2, handles, FALSE, INFINITE); - } while ((action != WAIT_OBJECT_0) && (action != WAIT_OBJECT_0 + 1)); - - if (action == WAIT_OBJECT_0 + 1) break; + // event raised when work is added to the queue + WaitForSingleObject(kickoff_event, INFINITE); #ifdef SMP_DEBUG fprintf(STDERR, "Server[%2ld] Got it.\n", cpu); #endif - EnterCriticalSection(&pool.lock); +#if 1 + EnterCriticalSection(&queue_lock); - queue = pool.queue; - if (queue) pool.queue = queue->next; + queue = work_queue; + if (queue) + work_queue = work_queue->next; - LeaveCriticalSection(&pool.lock); + LeaveCriticalSection(&queue_lock); +#else + volatile work_queue_t* queue_next; + + INT_PTR prev_value; + do { + queue = (volatile work_queue_t*)work_queue; + if (!queue) + break; + + queue_next = (volatile work_queue_t*)queue->next; + prev_value = WIN_CAS((INT_PTR*)&work_queue, (INT_PTR)queue_next, (INT_PTR)queue); + } while (prev_value != work_item); +#endif if (queue) { int (*routine)(blas_arg_t *, void *, void *, void *, void *, BLASLONG) = queue -> routine; - if (pool.queue) SetEvent(pool.filled); - sa = queue -> sa; sb = queue -> sb; @@ -331,14 +344,6 @@ static DWORD WINAPI blas_thread_server(void *arg){ #ifdef SMP_DEBUG fprintf(STDERR, "Server[%2ld] Finished!\n", cpu); #endif - - EnterCriticalSection(&queue->lock); - - queue -> status = BLAS_STATUS_FINISHED; - - LeaveCriticalSection(&queue->lock); - - SetEvent(queue->finish); } /* Shutdown procedure */ @@ -366,13 +371,10 @@ int blas_thread_init(void){ #endif if (!blas_server_avail){ + // create the kickoff Event + kickoff_event = CreateEvent(NULL, TRUE, FALSE, NULL); - InitializeCriticalSection(&pool.lock); - pool.filled = CreateEvent(NULL, FALSE, FALSE, NULL); - pool.killed = CreateEvent(NULL, TRUE, FALSE, NULL); - - pool.shutdown = 0; - pool.queue = NULL; + InitializeCriticalSection(&queue_lock); for(i = 0; i < blas_cpu_number - 1; i++){ blas_threads[i] = CreateThread(NULL, 0, @@ -409,8 +411,6 @@ int exec_blas_async(BLASLONG pos, blas_queue_t *queue){ current = queue; while (current) { - InitializeCriticalSection(¤t -> lock); - current -> finish = CreateEvent(NULL, FALSE, FALSE, NULL); current -> position = pos; #ifdef CONSISTENT_FPCSR @@ -418,23 +418,32 @@ int exec_blas_async(BLASLONG pos, blas_queue_t *queue){ __asm__ __volatile__ ("stmxcsr %0" : "=m" (current -> sse_mode)); #endif + current->finished = 0; current = current -> next; pos ++; } - EnterCriticalSection(&pool.lock); + EnterCriticalSection(&queue_lock); - if (pool.queue) { - current = pool.queue; - while (current -> next) current = current -> next; - current -> next = queue; - } else { - pool.queue = queue; + if (!work_queue) + { + work_queue = queue; } + else + { + blas_queue_t *next_item = work_queue; - LeaveCriticalSection(&pool.lock); + // find the end of the work queue + while (next_item) + next_item = next_item->next; - SetEvent(pool.filled); + // add new work to the end + next_item = queue; + } + + LeaveCriticalSection(&queue_lock); + + SetEvent(kickoff_event); return 0; } @@ -449,21 +458,26 @@ int exec_blas_async_wait(BLASLONG num, blas_queue_t *queue){ #ifdef SMP_DEBUG fprintf(STDERR, "Waiting Queue ..\n"); #endif + while (!queue->finished) + YIELDING; - WaitForSingleObject(queue->finish, INFINITE); - - CloseHandle(queue->finish); - DeleteCriticalSection(&queue -> lock); - - queue = queue -> next; - num --; + queue = queue->next; + num--; } #ifdef SMP_DEBUG fprintf(STDERR, "Completely Done.\n\n"); #endif + // if work was added to the queue after this batch we can't sleep the worker threads + // by resetting the event + EnterCriticalSection(&queue_lock); - return 0; + if (work_queue == NULL) + ResetEvent(kickoff_event); + + LeaveCriticalSection(&queue_lock); + + return 0; } /* Execute Threads */ @@ -512,8 +526,6 @@ int BLASFUNC(blas_thread_shutdown)(void){ if (blas_server_avail){ - SetEvent(pool.killed); - for(i = 0; i < blas_num_threads - 1; i++){ // Could also just use WaitForMultipleObjects DWORD wait_thread_value = WaitForSingleObject(blas_threads[i], 50); @@ -528,9 +540,6 @@ int BLASFUNC(blas_thread_shutdown)(void){ CloseHandle(blas_threads[i]); } - CloseHandle(pool.filled); - CloseHandle(pool.killed); - blas_server_avail = 0; } @@ -558,13 +567,11 @@ void goto_set_num_threads(int num_threads) //increased_threads = 1; if (!blas_server_avail){ + // create the kickoff Event + kickoff_event = CreateEvent(NULL, TRUE, FALSE, NULL); - InitializeCriticalSection(&pool.lock); - pool.filled = CreateEvent(NULL, FALSE, FALSE, NULL); - pool.killed = CreateEvent(NULL, TRUE, FALSE, NULL); + InitializeCriticalSection(&queue_lock); - pool.shutdown = 0; - pool.queue = NULL; blas_server_avail = 1; } From 4ebf814b4258904d1f48bfe427a6727514d9efa6 Mon Sep 17 00:00:00 2001 From: Mark Seminatore Date: Tue, 5 Dec 2023 23:28:37 -0800 Subject: [PATCH 42/60] fix bug failing to mark task as finished. --- driver/others/blas_server_win32.c | 3 +++ 1 file changed, 3 insertions(+) diff --git a/driver/others/blas_server_win32.c b/driver/others/blas_server_win32.c index 464e3fa03..5af1f1a51 100644 --- a/driver/others/blas_server_win32.c +++ b/driver/others/blas_server_win32.c @@ -344,6 +344,9 @@ static DWORD WINAPI blas_thread_server(void *arg){ #ifdef SMP_DEBUG fprintf(STDERR, "Server[%2ld] Finished!\n", cpu); #endif + + queue->finished = 1; + } /* Shutdown procedure */ From 993ede7c70658870921b446b145310f1b6c1edf6 Mon Sep 17 00:00:00 2001 From: yancheng Date: Mon, 27 Nov 2023 11:30:34 +0800 Subject: [PATCH 43/60] loongarch64: Add optimizations for scal. --- kernel/loongarch64/KERNEL.LOONGSON2K1000 | 3 + kernel/loongarch64/KERNEL.LOONGSON3R5 | 3 + kernel/loongarch64/dscal_lasx.S | 194 +++++++++++++++++++++ kernel/loongarch64/dscal_lsx.S | 205 +++++++++++++++++++++++ kernel/loongarch64/sscal_lasx.S | 188 +++++++++++++++++++++ kernel/loongarch64/sscal_lsx.S | 194 +++++++++++++++++++++ 6 files changed, 787 insertions(+) create mode 100644 kernel/loongarch64/dscal_lasx.S create mode 100644 kernel/loongarch64/dscal_lsx.S create mode 100644 kernel/loongarch64/sscal_lasx.S create mode 100644 kernel/loongarch64/sscal_lsx.S diff --git a/kernel/loongarch64/KERNEL.LOONGSON2K1000 b/kernel/loongarch64/KERNEL.LOONGSON2K1000 index b2a396674..e553c4b95 100644 --- a/kernel/loongarch64/KERNEL.LOONGSON2K1000 +++ b/kernel/loongarch64/KERNEL.LOONGSON2K1000 @@ -4,4 +4,7 @@ SDOTKERNEL = dot_lsx.S DSDOTKERNEL = dot_lsx.S DDOTKERNEL = dot_lsx.S +SSCALKERNEL = sscal_lsx.S +DSCALKERNEL = dscal_lsx.S + endif diff --git a/kernel/loongarch64/KERNEL.LOONGSON3R5 b/kernel/loongarch64/KERNEL.LOONGSON3R5 index 020a82303..4c0c1c2c8 100644 --- a/kernel/loongarch64/KERNEL.LOONGSON3R5 +++ b/kernel/loongarch64/KERNEL.LOONGSON3R5 @@ -4,6 +4,9 @@ SDOTKERNEL = dot_lasx.S DSDOTKERNEL = dot_lasx.S DDOTKERNEL = dot_lasx.S +SSCALKERNEL = sscal_lasx.S +DSCALKERNEL = dscal_lasx.S + DGEMMKERNEL = dgemm_kernel_16x4.S DGEMMINCOPY = dgemm_ncopy_16.S DGEMMITCOPY = dgemm_tcopy_16.S diff --git a/kernel/loongarch64/dscal_lasx.S b/kernel/loongarch64/dscal_lasx.S new file mode 100644 index 000000000..153662378 --- /dev/null +++ b/kernel/loongarch64/dscal_lasx.S @@ -0,0 +1,194 @@ +#define ASSEMBLER +#include "common.h" + +#define N $r4 +#define ALPHA $f0 +#define X $r7 +#define INCX $r8 +#define I $r12 +#define TEMP $r13 +#define t1 $r14 +#define t2 $r18 +#define t3 $r15 +#define t4 $r17 +#define XX $r16 +#define VX0 $xr12 +#define VX1 $xr13 +#define VT0 $xr14 +#define VT1 $xr15 +#define VALPHA $xr19 +#define a1 $f8 +#define a2 $f23 + + PROLOGUE + + bge $r0, N, .L999 + bge $r0, INCX, .L999 + li.d TEMP, 1 + movgr2fr.d a1, $r0 + ffint.d.l a1, a1 + movgr2fr.d a2, TEMP + ffint.d.l a2, a2 + slli.d TEMP, TEMP, BASE_SHIFT + slli.d INCX, INCX, BASE_SHIFT + fcmp.ceq.d $fcc0, ALPHA, a1 + bcnez $fcc0, .L20 //ALPHA==0 + fcmp.ceq.d $fcc0, ALPHA, a2 + bcnez $fcc0, .L999 //ALPHA==1 return + srai.d I, N, 3 + beq INCX, TEMP, .L30 //ALPHA！=0|1 and INCX==1 + movfr2gr.d TEMP, ALPHA + xvreplgr2vr.d VALPHA, TEMP + move XX, X + .align 3 + +.L10: + bge $r0, I, .L32 + .align 3 +.L11: + ld.d t1, X, 0 * SIZE + add.d X, X, INCX + ld.d t2, X, 0 * SIZE + add.d X, X, INCX + ld.d t3, X, 0 * SIZE + add.d X, X, INCX + ld.d t4, X, 0 * SIZE + add.d X, X, INCX + xvinsgr2vr.d VX0, t1, 0 + xvinsgr2vr.d VX0, t2, 1 + xvinsgr2vr.d VX0, t3, 2 + xvinsgr2vr.d VX0, t4, 3 + ld.d t1, X, 0 * SIZE + add.d X, X, INCX + ld.d t2, X, 0 * SIZE + add.d X, X, INCX + xvfmul.d VT0, VX0, VALPHA + ld.d t3, X, 0 * SIZE + add.d X, X, INCX + ld.d t4, X, 0 * SIZE + add.d X, X, INCX + xvinsgr2vr.d VX1, t1, 0 + xvinsgr2vr.d VX1, t2, 1 + xvinsgr2vr.d VX1, t3, 2 + xvinsgr2vr.d VX1, t4, 3 + xvstelm.d VT0, XX, 0, 0 + add.d XX, XX, INCX + xvstelm.d VT0, XX, 0, 1 + add.d XX, XX, INCX + xvstelm.d VT0, XX, 0, 2 + add.d XX, XX, INCX + xvstelm.d VT0, XX, 0, 3 + add.d XX, XX, INCX + xvfmul.d VT1, VX1, VALPHA + xvstelm.d VT1, XX, 0, 0 + add.d XX, XX, INCX + xvstelm.d VT1, XX, 0, 1 + add.d XX, XX, INCX + xvstelm.d VT1, XX, 0, 2 + add.d XX, XX, INCX + xvstelm.d VT1, XX, 0, 3 + add.d XX, XX, INCX + addi.d I, I, -1 + blt $r0, I, .L11 + b .L32 + .align 3 + +.L20: + srai.d I, N, 3 + beq INCX, TEMP, .L24 + bge $r0, I, .L22 + .align 3 + +.L21: + fst.d a1, X, 0 + add.d X, X, INCX + fst.d a1, X, 0 + add.d X, X, INCX + fst.d a1, X, 0 + add.d X, X, INCX + fst.d a1, X, 0 + add.d X, X, INCX + fst.d a1, X, 0 + add.d X, X, INCX + fst.d a1, X, 0 + add.d X, X, INCX + fst.d a1, X, 0 + add.d X, X, INCX + fst.d a1, X, 0 + add.d X, X, INCX + addi.d I, I, -1 + blt $r0, I, .L21 + .align 3 + +.L22: + andi I, N, 7 + bge $r0, I, .L999 + .align 3 +.L23: + fst.d a1, X, 0 * SIZE + addi.d I, I, -1 + add.d X, X, INCX + blt $r0, I, .L23 + jirl $r0, $r1, 0 + .align 3 + +.L24: + bge $r0, I, .L26 /*N<8 INCX==1*/ + .align 3 +.L25: + xvxor.v VX0, VX0, VX0 + xvst VX0, X, 0 * SIZE + xvst VX0, X, 4 * SIZE + addi.d I, I, -1 + addi.d X, X, 8 * SIZE + blt $r0, I, .L25 + .align 3 + +.L26: + andi I, N, 7 + bge $r0, I, .L999 + .align 3 +.L27: + fst.d a1, X, 0 * SIZE + addi.d I, I, -1 + addi.d X, X, SIZE + blt $r0, I, .L27 + jirl $r0, $r1, 0 + .align 3 + +.L30: + bge $r0, I, .L32/*N<8 INCX==1*/ + movfr2gr.d TEMP, ALPHA + xvreplgr2vr.d VALPHA , TEMP + .align 3 + +.L31: + xvld VX0, X, 0 * SIZE + xvld VX1, X, 4 * SIZE + xvfmul.d VT0, VX0, VALPHA + xvfmul.d VT1, VX1, VALPHA + addi.d I, I, -1 + xvst VT0, X, 0 * SIZE + xvst VT1, X, 4 * SIZE + addi.d X, X, 8 * SIZE + blt $r0, I, .L31 + .align 3 + +.L32: + andi I, N, 7 + bge $r0, I, .L999 + .align 3 +.L33: + fld.d a1, X, 0 * SIZE + addi.d I, I, -1 + fmul.d a1, ALPHA, a1 + fst.d a1, X, 0 * SIZE + add.d X, X, INCX + blt $r0, I, .L33 + jirl $r0, $r1, 0 + .align 3 + +.L999: + jirl $r0, $r1, 0x0 + + EPILOGUE diff --git a/kernel/loongarch64/dscal_lsx.S b/kernel/loongarch64/dscal_lsx.S new file mode 100644 index 000000000..55f497752 --- /dev/null +++ b/kernel/loongarch64/dscal_lsx.S @@ -0,0 +1,205 @@ +#define ASSEMBLER +#include "common.h" + +#define N $r4 +#define ALPHA $f0 +#define X $r7 +#define INCX $r8 +#define I $r12 +#define TEMP $r13 +#define t1 $r14 +#define t2 $r18 +#define t3 $r15 +#define t4 $r17 +#define XX $r16 +#define VX0 $vr12 +#define VX1 $vr13 +#define VT0 $vr14 +#define VT1 $vr15 +#define VALPHA $vr19 +#define a1 $f8 +#define a2 $f23 + + PROLOGUE + + bge $r0, N, .L999 + bge $r0, INCX, .L999 + li.d TEMP, 1 + movgr2fr.d a1, $r0 + ffint.d.l a1, a1 + movgr2fr.d a2, TEMP + ffint.d.l a2, a2 + slli.d TEMP, TEMP, BASE_SHIFT + slli.d INCX, INCX, BASE_SHIFT + fcmp.ceq.d $fcc0, ALPHA, a1 + bcnez $fcc0, .L20 //ALPHA==0 + fcmp.ceq.d $fcc0, ALPHA, a2 + bcnez $fcc0, .L999 //ALPHA==1 return + srai.d I, N, 3 + beq INCX, TEMP, .L30 //ALPHA！=0|1 and INCX==1 + movfr2gr.d TEMP, ALPHA + vreplgr2vr.d VALPHA, TEMP + move XX, X + .align 3 + +.L10: //ALPHA！=0|1 and INCX!=1 + bge $r0, I, .L32 + .align 3 + +.L11: + ld.d t1, X, 0 * SIZE + add.d X, X, INCX + ld.d t2, X, 0 * SIZE + add.d X, X, INCX + vinsgr2vr.d VX0, t1, 0 + vinsgr2vr.d VX0, t2, 1 + vfmul.d VT0, VX0, VALPHA + ld.d t3, X, 0 * SIZE + add.d X, X, INCX + ld.d t4, X, 0 * SIZE + add.d X, X, INCX + vinsgr2vr.d VX1, t3, 0 + vinsgr2vr.d VX1, t4, 1 + vstelm.d VT0, XX, 0, 0 + add.d XX, XX, INCX + vstelm.d VT0, XX, 0, 1 + add.d XX, XX, INCX + vfmul.d VT1, VX1, VALPHA + ld.d t1, X, 0 * SIZE + add.d X, X, INCX + ld.d t2, X, 0 * SIZE + add.d X, X, INCX + vinsgr2vr.d VX0, t1, 0 + vinsgr2vr.d VX0, t2, 1 + vstelm.d VT1, XX, 0, 0 + add.d XX, XX, INCX + vstelm.d VT1, XX, 0, 1 + add.d XX, XX, INCX + vfmul.d VT0, VX0, VALPHA + ld.d t3, X, 0 * SIZE + add.d X, X, INCX + ld.d t4, X, 0 * SIZE + add.d X, X, INCX + vinsgr2vr.d VX1, t3, 0 + vinsgr2vr.d VX1, t4, 1 + vstelm.d VT0, XX, 0, 0 + add.d XX, XX, INCX + vstelm.d VT0, XX, 0, 1 + add.d XX, XX, INCX + vfmul.d VT1, VX1, VALPHA + vstelm.d VT1, XX, 0, 0 + add.d XX, XX, INCX + vstelm.d VT1, XX, 0, 1 + add.d XX, XX, INCX + addi.d I, I, -1 + blt $r0, I, .L11 + b .L32 + .align 3 + +.L20: + srai.d I, N, 3 + beq INCX, TEMP, .L24 + bge $r0, I, .L22 + .align 3 + +.L21: + fst.d a1, X, 0 + add.d X, X, INCX + fst.d a1, X, 0 + add.d X, X, INCX + fst.d a1, X, 0 + add.d X, X, INCX + fst.d a1, X, 0 + add.d X, X, INCX + fst.d a1, X, 0 + add.d X, X, INCX + fst.d a1, X, 0 + add.d X, X, INCX + fst.d a1, X, 0 + add.d X, X, INCX + fst.d a1, X, 0 + add.d X, X, INCX + addi.d I, I, -1 + blt $r0, I, .L21 + .align 3 + +.L22: + andi I, N, 7 + bge $r0, I, .L999 + .align 3 +.L23: + fst.d a1, X, 0 * SIZE + addi.d I, I, -1 + add.d X, X, INCX + blt $r0, I, .L23 + jirl $r0, $r1, 0 + .align 3 + +.L24: + bge $r0, I, .L26 /*N<8 INCX==1*/ + .align 3 +.L25: + vxor.v VX0, VX0, VX0 + vst VX0, X, 0 * SIZE + vst VX0, X, 2 * SIZE + vst VX0, X, 4 * SIZE + vst VX0, X, 6 * SIZE + addi.d I, I, -1 + addi.d X, X, 8 * SIZE + blt $r0, I, .L25 + .align 3 + +.L26: + andi I, N, 7 + bge $r0, I, .L999 + .align 3 +.L27: + fst.d a1, X, 0 * SIZE + addi.d I, I, -1 + addi.d X, X, SIZE + blt $r0, I, .L27 + jirl $r0, $r1, 0 + .align 3 + +.L30: + bge $r0, I, .L32/*N<8 INCX==1*/ + movfr2gr.d TEMP, ALPHA + vreplgr2vr.d VALPHA , TEMP + .align 3 + +.L31: + vld VX0, X, 0 * SIZE + vld VX1, X, 2 * SIZE + vfmul.d VT0, VX0, VALPHA + vfmul.d VT1, VX1, VALPHA + vld VX0, X, 4 * SIZE + vst VT0, X, 0 * SIZE + vst VT1, X, 2 * SIZE + vfmul.d VT0, VX0, VALPHA + vld VX1, X, 6 * SIZE + vst VT0, X, 4 * SIZE + vfmul.d VT1, VX1, VALPHA + vst VT1, X, 6 * SIZE + addi.d I, I, -1 + addi.d X, X, 8 * SIZE + blt $r0, I, .L31 + .align 3 + +.L32: + andi I, N, 7 + bge $r0, I, .L999 + .align 3 +.L33: + fld.d a1, X, 0 * SIZE + addi.d I, I, -1 + fmul.d a1, ALPHA, a1 + fst.d a1, X, 0 * SIZE + add.d X, X, INCX + blt $r0, I, .L33 + jirl $r0, $r1, 0 + .align 3 + +.L999: + jirl $r0, $r1, 0x0 + + EPILOGUE diff --git a/kernel/loongarch64/sscal_lasx.S b/kernel/loongarch64/sscal_lasx.S new file mode 100644 index 000000000..329f24659 --- /dev/null +++ b/kernel/loongarch64/sscal_lasx.S @@ -0,0 +1,188 @@ +#define ASSEMBLER +#include "common.h" + +#define N $r4 +#define ALPHA $f0 +#define X $r7 +#define INCX $r8 +#define I $r12 +#define TEMP $r13 +#define t1 $r14 +#define t2 $r18 +#define t3 $r15 +#define t4 $r17 +#define XX $r16 +#define VX0 $xr12 +#define VX1 $xr13 +#define VT0 $xr14 +#define VT1 $xr15 +#define VALPHA $xr19 +#define a1 $f8 +#define a2 $f23 + + PROLOGUE + + bge $r0, N, .L999 + bge $r0, INCX, .L999 + li.d TEMP, 1 + movgr2fr.d a1, $r0 + ffint.s.l a1, a1 + movgr2fr.d a2, TEMP + ffint.s.l a2, a2 + slli.d TEMP, TEMP, BASE_SHIFT + slli.d INCX, INCX, BASE_SHIFT + fcmp.ceq.s $fcc0, ALPHA, a1 + bcnez $fcc0, .L20 //ALPHA==0 + fcmp.ceq.s $fcc0, ALPHA, a2 + bcnez $fcc0, .L999 //ALPHA==1 return + srai.d I, N, 3 + beq INCX, TEMP, .L30 //ALPHA！=0|1 and INCX==1 + movfr2gr.s TEMP, ALPHA + xvreplgr2vr.w VALPHA, TEMP + move XX, X + +.L10: //ALPHA！=0|1 and INCX!=1 + bge $r0, I, .L32 + .align 3 +.L11: + ld.w t1, X, 0 * SIZE + add.d X, X, INCX + ld.w t2, X, 0 * SIZE + add.d X, X, INCX + ld.w t3, X, 0 * SIZE + add.d X, X, INCX + ld.w t4, X, 0 * SIZE + add.d X, X, INCX + xvinsgr2vr.w VX0, t1, 0 + xvinsgr2vr.w VX0, t2, 1 + xvinsgr2vr.w VX0, t3, 2 + xvinsgr2vr.w VX0, t4, 3 + ld.w t1, X, 0 * SIZE + add.d X, X, INCX + ld.w t2, X, 0 * SIZE + add.d X, X, INCX + ld.w t3, X, 0 * SIZE + add.d X, X, INCX + ld.w t4, X, 0 * SIZE + add.d X, X, INCX + xvinsgr2vr.w VX0, t1, 4 + xvinsgr2vr.w VX0, t2, 5 + xvinsgr2vr.w VX0, t3, 6 + xvinsgr2vr.w VX0, t4, 7 + xvfmul.s VT0, VX0, VALPHA + xvstelm.w VT0, XX, 0, 0 + add.d XX, XX, INCX + xvstelm.w VT0, XX, 0, 1 + add.d XX, XX, INCX + xvstelm.w VT0, XX, 0, 2 + add.d XX, XX, INCX + xvstelm.w VT0, XX, 0, 3 + add.d XX, XX, INCX + xvstelm.w VT0, XX, 0, 4 + add.d XX, XX, INCX + xvstelm.w VT0, XX, 0, 5 + add.d XX, XX, INCX + xvstelm.w VT0, XX, 0, 6 + add.d XX, XX, INCX + xvstelm.w VT0, XX, 0, 7 + add.d XX, XX, INCX + addi.d I, I, -1 + blt $r0, I, .L11 + b .L32 + .align 3 + +.L20: + srai.d I, N, 3 + beq INCX, TEMP, .L24 + bge $r0, I, .L22 + .align 3 + +.L21: + fst.s a1, X, 0 + add.d X, X, INCX + fst.s a1, X, 0 + add.d X, X, INCX + fst.s a1, X, 0 + add.d X, X, INCX + fst.s a1, X, 0 + add.d X, X, INCX + fst.s a1, X, 0 + add.d X, X, INCX + fst.s a1, X, 0 + add.d X, X, INCX + fst.s a1, X, 0 + add.d X, X, INCX + fst.s a1, X, 0 + add.d X, X, INCX + addi.d I, I, -1 + blt $r0, I, .L21 + .align 3 + +.L22: + andi I, N, 7 + bge $r0, I, .L999 + .align 3 +.L23: + fst.s a1, X, 0 * SIZE + addi.d I, I, -1 + add.d X, X, INCX + blt $r0, I, .L23 + jirl $r0, $r1, 0 + .align 3 + +.L24: + bge $r0, I, .L26 /*N<8 INCX==1*/ + .align 3 +.L25: + xvxor.v VX0, VX0, VX0 + xvst VX0, X, 0 * SIZE + addi.d I, I, -1 + addi.d X, X, 8 * SIZE + blt $r0, I, .L25 + .align 3 + +.L26: + andi I, N, 7 + bge $r0, I, .L999 + .align 3 +.L27: + fst.s a1, X, 0 * SIZE + addi.d I, I, -1 + addi.d X, X, SIZE + blt $r0, I, .L27 + jirl $r0, $r1, 0 + .align 3 + +.L30: + bge $r0, I, .L32/*N<8 INCX==1*/ + movfr2gr.s TEMP, ALPHA + xvreplgr2vr.w VALPHA , TEMP + .align 3 + +.L31: + xvld VX0, X, 0 * SIZE + addi.d I, I, -1 + xvfmul.s VT0, VX0, VALPHA + xvst VT0, X, 0 * SIZE + addi.d X, X, 8 * SIZE + blt $r0, I, .L31 + .align 3 + +.L32: + andi I, N, 7 + bge $r0, I, .L999 + .align 3 +.L33: + fld.s a1, X, 0 * SIZE + addi.d I, I, -1 + fmul.s a1, ALPHA, a1 + fst.s a1, X, 0 * SIZE + add.d X, X, INCX + blt $r0, I, .L33 + jirl $r0, $r1, 0 + .align 3 + +.L999: + jirl $r0, $r1, 0x0 + + EPILOGUE diff --git a/kernel/loongarch64/sscal_lsx.S b/kernel/loongarch64/sscal_lsx.S new file mode 100644 index 000000000..d0ea1307d --- /dev/null +++ b/kernel/loongarch64/sscal_lsx.S @@ -0,0 +1,194 @@ +#define ASSEMBLER +#include "common.h" + +#define N $r4 +#define ALPHA $f0 +#define X $r7 +#define INCX $r8 +#define I $r12 +#define TEMP $r13 +#define t1 $r14 +#define t2 $r18 +#define t3 $r15 +#define t4 $r17 +#define XX $r16 +#define VX0 $vr12 +#define VX1 $vr13 +#define VT0 $vr14 +#define VT1 $vr15 +#define VALPHA $vr19 +#define a1 $f8 +#define a2 $f23 + + PROLOGUE + + bge $r0, N, .L999 + bge $r0, INCX, .L999 + li.d TEMP, 1 + movgr2fr.d a1, $r0 + ffint.s.l a1, a1 + movgr2fr.d a2, TEMP + ffint.s.l a2, a2 + slli.d TEMP, TEMP, BASE_SHIFT + slli.d INCX, INCX, BASE_SHIFT + fcmp.ceq.s $fcc0, ALPHA, a1 + bcnez $fcc0, .L20 //ALPHA==0 + fcmp.ceq.s $fcc0, ALPHA, a2 + bcnez $fcc0, .L999 //ALPHA==1 return + srai.d I, N, 3 + beq INCX, TEMP, .L30 //ALPHA！=0|1 and INCX==1 + movfr2gr.s TEMP, ALPHA + vreplgr2vr.w VALPHA, TEMP + move XX, X + .align 3 + +.L10: //ALPHA！=0|1 and INCX!=1 + bge $r0, I, .L32 + .align 3 +.L11: + ld.w t1, X, 0 * SIZE + add.d X, X, INCX + ld.w t2, X, 0 * SIZE + add.d X, X, INCX + ld.w t3, X, 0 * SIZE + add.d X, X, INCX + ld.w t4, X, 0 * SIZE + add.d X, X, INCX + vinsgr2vr.w VX0, t1, 0 + vinsgr2vr.w VX0, t2, 1 + vinsgr2vr.w VX0, t3, 2 + vinsgr2vr.w VX0, t4, 3 + ld.w t1, X, 0 * SIZE + add.d X, X, INCX + ld.w t2, X, 0 * SIZE + add.d X, X, INCX + vfmul.s VT0, VX0, VALPHA + ld.w t3, X, 0 * SIZE + add.d X, X, INCX + ld.w t4, X, 0 * SIZE + add.d X, X, INCX + vinsgr2vr.w VX1, t1, 0 + vinsgr2vr.w VX1, t2, 1 + vinsgr2vr.w VX1, t3, 2 + vinsgr2vr.w VX1, t4, 3 + vstelm.w VT0, XX, 0, 0 + add.d XX, XX, INCX + vstelm.w VT0, XX, 0, 1 + add.d XX, XX, INCX + vstelm.w VT0, XX, 0, 2 + add.d XX, XX, INCX + vstelm.w VT0, XX, 0, 3 + add.d XX, XX, INCX + vfmul.s VT1, VX1, VALPHA + vstelm.w VT1, XX, 0, 0 + add.d XX, XX, INCX + vstelm.w VT1, XX, 0, 1 + add.d XX, XX, INCX + vstelm.w VT1, XX, 0, 2 + add.d XX, XX, INCX + vstelm.w VT1, XX, 0, 3 + add.d XX, XX, INCX + addi.d I, I, -1 + blt $r0, I, .L11 + b .L32 + .align 3 + +.L20: + srai.d I, N, 3 + beq INCX, TEMP, .L24 + bge $r0, I, .L22 + .align 3 + +.L21: + fst.s a1, X, 0 + add.d X, X, INCX + fst.s a1, X, 0 + add.d X, X, INCX + fst.s a1, X, 0 + add.d X, X, INCX + fst.s a1, X, 0 + add.d X, X, INCX + fst.s a1, X, 0 + add.d X, X, INCX + fst.s a1, X, 0 + add.d X, X, INCX + fst.s a1, X, 0 + add.d X, X, INCX + fst.s a1, X, 0 + add.d X, X, INCX + addi.d I, I, -1 + blt $r0, I, .L21 + .align 3 + +.L22: + andi I, N, 7 + bge $r0, I, .L999 + .align 3 +.L23: + fst.s a1, X, 0 * SIZE + addi.d I, I, -1 + add.d X, X, INCX + blt $r0, I, .L23 + jirl $r0, $r1, 0 + .align 3 + +.L24: + bge $r0, I, .L26 /*N<8 INCX==1*/ + .align 3 +.L25: + vxor.v VX0, VX0, VX0 + vst VX0, X, 0 * SIZE + vst VX0, X, 4 * SIZE + addi.d I, I, -1 + addi.d X, X, 8 * SIZE + blt $r0, I, .L25 + .align 3 + +.L26: + andi I, N, 7 + bge $r0, I, .L999 + .align 3 +.L27: + fst.s a1, X, 0 * SIZE + addi.d I, I, -1 + addi.d X, X, SIZE + blt $r0, I, .L27 + jirl $r0, $r1, 0 + .align 3 + +.L30: + bge $r0, I, .L32/*N<8 INCX==1*/ + movfr2gr.s TEMP, ALPHA + vreplgr2vr.w VALPHA , TEMP + .align 3 + +.L31: + vld VX0, X, 0 * SIZE + vld VX1, X, 4 * SIZE + vfmul.s VT0, VX0, VALPHA + vfmul.s VT1, VX1, VALPHA + addi.d I, I, -1 + vst VT0, X, 0 * SIZE + vst VT1, X, 4 * SIZE + addi.d X, X, 8 * SIZE + blt $r0, I, .L31 + .align 3 + +.L32: + andi I, N, 7 + bge $r0, I, .L999 + .align 3 +.L33: + fld.s a1, X, 0 * SIZE + addi.d I, I, -1 + fmul.s a1, ALPHA, a1 + fst.s a1, X, 0 * SIZE + add.d X, X, INCX + blt $r0, I, .L33 + jirl $r0, $r1, 0 + .align 3 + +.L999: + jirl $r0, $r1, 0x0 + + EPILOGUE From 265b5f2e803d2d66b7fe75ec356dc14fcb5ef726 Mon Sep 17 00:00:00 2001 From: yancheng Date: Thu, 7 Dec 2023 10:57:13 +0800 Subject: [PATCH 44/60] loongarch64: Add optimizations for amax. --- kernel/loongarch64/KERNEL.LOONGSON2K1000 | 3 + kernel/loongarch64/KERNEL.LOONGSON3R5 | 3 + kernel/loongarch64/damax_lasx.S | 183 ++++++++++++++++++++ kernel/loongarch64/damax_lsx.S | 145 ++++++++++++++++ kernel/loongarch64/samax_lasx.S | 208 +++++++++++++++++++++++ kernel/loongarch64/samax_lsx.S | 177 +++++++++++++++++++ 6 files changed, 719 insertions(+) create mode 100644 kernel/loongarch64/damax_lasx.S create mode 100644 kernel/loongarch64/damax_lsx.S create mode 100644 kernel/loongarch64/samax_lasx.S create mode 100644 kernel/loongarch64/samax_lsx.S diff --git a/kernel/loongarch64/KERNEL.LOONGSON2K1000 b/kernel/loongarch64/KERNEL.LOONGSON2K1000 index e553c4b95..a4d5f8f87 100644 --- a/kernel/loongarch64/KERNEL.LOONGSON2K1000 +++ b/kernel/loongarch64/KERNEL.LOONGSON2K1000 @@ -7,4 +7,7 @@ DDOTKERNEL = dot_lsx.S SSCALKERNEL = sscal_lsx.S DSCALKERNEL = dscal_lsx.S +SAMAXKERNEL = samax_lsx.S +DAMAXKERNEL = damax_lsx.S + endif diff --git a/kernel/loongarch64/KERNEL.LOONGSON3R5 b/kernel/loongarch64/KERNEL.LOONGSON3R5 index 4c0c1c2c8..8c7481ae6 100644 --- a/kernel/loongarch64/KERNEL.LOONGSON3R5 +++ b/kernel/loongarch64/KERNEL.LOONGSON3R5 @@ -7,6 +7,9 @@ DDOTKERNEL = dot_lasx.S SSCALKERNEL = sscal_lasx.S DSCALKERNEL = dscal_lasx.S +SAMAXKERNEL = samax_lasx.S +DAMAXKERNEL = damax_lasx.S + DGEMMKERNEL = dgemm_kernel_16x4.S DGEMMINCOPY = dgemm_ncopy_16.S DGEMMITCOPY = dgemm_tcopy_16.S diff --git a/kernel/loongarch64/damax_lasx.S b/kernel/loongarch64/damax_lasx.S new file mode 100644 index 000000000..c44ce4995 --- /dev/null +++ b/kernel/loongarch64/damax_lasx.S @@ -0,0 +1,183 @@ +#define ASSEMBLER + +#include "common.h" + +#define N $r4 +#define X $r5 +#define INCX $r6 +#define I $r12 +#define J $r13 +#define t1 $r14 +#define t2 $r18 +#define t3 $r15 +#define t4 $r17 +#define TEMP $r16 +#define m0 $xr8 +#define x1 $xr9 +#define x2 $xr10 +#define x3 $xr11 +#define x4 $xr12 +#define x5 $xr13 +#define x6 $xr14 +#define x7 $xr15 +#define x8 $xr16 +#define VX0 $xr20 +#define VX1 $xr21 +#define VM0 $xr22 +#define VM1 $xr23 +#define VM2 $xr18 +#define VM3 $xr19 + + PROLOGUE + + bge $r0, N, .L999 + bge $r0, INCX, .L999 + li.d TEMP, 1 + slli.d TEMP, TEMP, BASE_SHIFT + slli.d INCX, INCX, BASE_SHIFT + bne INCX, TEMP, .L20 + xvld VM0, X, 0 + srai.d I, N, 3 + bge $r0, I, .L12 + .align 3 + +.L10: + xvld VX0, X, 0 * SIZE + xvld VX1, X, 4 * SIZE + addi.d I, I, -1 + xvfmaxa.d VM1, VX1, VX0 + addi.d X, X, 8 * SIZE + xvfmaxa.d VM0, VM0, VM1 + blt $r0, I, .L10 + .align 3 + +.L11: + xvpickve.d x1, VM0, 0 + xvpickve.d x2, VM0, 1 + xvpickve.d x3, VM0, 2 + xvpickve.d x4, VM0, 3 + xvfmaxa.d VM1, x1, x2 + xvfmaxa.d VM2, x3, x4 + xvfmaxa.d VM0, VM1, VM2 + .align 3 + +.L12: //INCX==1 and N<8 + andi I, N, 7 + li.d J, 4 + bge J, I, .L13 // 4 Date: Thu, 7 Dec 2023 11:08:09 +0800 Subject: [PATCH 45/60] loongarch64: Add optimization for amin. --- kernel/loongarch64/KERNEL.LOONGSON2K1000 | 3 + kernel/loongarch64/KERNEL.LOONGSON3R5 | 3 + kernel/loongarch64/damin_lasx.S | 178 +++++++++++++++++++ kernel/loongarch64/damin_lsx.S | 145 ++++++++++++++++ kernel/loongarch64/samin_lasx.S | 208 +++++++++++++++++++++++ kernel/loongarch64/samin_lsx.S | 177 +++++++++++++++++++ 6 files changed, 714 insertions(+) create mode 100644 kernel/loongarch64/damin_lasx.S create mode 100644 kernel/loongarch64/damin_lsx.S create mode 100644 kernel/loongarch64/samin_lasx.S create mode 100644 kernel/loongarch64/samin_lsx.S diff --git a/kernel/loongarch64/KERNEL.LOONGSON2K1000 b/kernel/loongarch64/KERNEL.LOONGSON2K1000 index a4d5f8f87..279ff6a9c 100644 --- a/kernel/loongarch64/KERNEL.LOONGSON2K1000 +++ b/kernel/loongarch64/KERNEL.LOONGSON2K1000 @@ -10,4 +10,7 @@ DSCALKERNEL = dscal_lsx.S SAMAXKERNEL = samax_lsx.S DAMAXKERNEL = damax_lsx.S +SAMINKERNEL = samin_lsx.S +DAMINKERNEL = damin_lsx.S + endif diff --git a/kernel/loongarch64/KERNEL.LOONGSON3R5 b/kernel/loongarch64/KERNEL.LOONGSON3R5 index 8c7481ae6..83db79050 100644 --- a/kernel/loongarch64/KERNEL.LOONGSON3R5 +++ b/kernel/loongarch64/KERNEL.LOONGSON3R5 @@ -10,6 +10,9 @@ DSCALKERNEL = dscal_lasx.S SAMAXKERNEL = samax_lasx.S DAMAXKERNEL = damax_lasx.S +SAMINKERNEL = samin_lasx.S +DAMINKERNEL = damin_lasx.S + DGEMMKERNEL = dgemm_kernel_16x4.S DGEMMINCOPY = dgemm_ncopy_16.S DGEMMITCOPY = dgemm_tcopy_16.S diff --git a/kernel/loongarch64/damin_lasx.S b/kernel/loongarch64/damin_lasx.S new file mode 100644 index 000000000..9d96dd997 --- /dev/null +++ b/kernel/loongarch64/damin_lasx.S @@ -0,0 +1,178 @@ +#define ASSEMBLER + +#include "common.h" + +#define N $r4 +#define X $r5 +#define INCX $r6 +#define I $r12 +#define J $r13 +#define t1 $r14 +#define t2 $r18 +#define t3 $r15 +#define t4 $r17 +#define TEMP $r16 +#define m0 $xr8 +#define x1 $xr9 +#define x2 $xr10 +#define x3 $xr11 +#define x4 $xr12 +#define VX0 $xr20 +#define VX1 $xr21 +#define VM0 $xr22 +#define VM1 $xr23 +#define VM2 $xr19 + + PROLOGUE + + bge $r0, N, .L999 + bge $r0, INCX, .L999 + li.d TEMP, 1 + slli.d TEMP, TEMP, BASE_SHIFT + slli.d INCX, INCX, BASE_SHIFT + bne INCX, TEMP, .L20 + xvld VM0, X, 0 + srai.d I, N, 3 + bge $r0, I, .L12 + .align 3 + +.L10: + xvld VX0, X, 0 * SIZE + addi.d I, I, -1 + xvld VX1, X, 4 * SIZE + xvfmina.d VM1, VX1, VX0 + addi.d X, X, 8 * SIZE + xvfmina.d VM0, VM0, VM1 + blt $r0, I, .L10 + .align 3 + +.L11: + xvpickve.d x1, VM0, 0 + xvpickve.d x2, VM0, 1 + xvpickve.d x3, VM0, 2 + xvpickve.d x4, VM0, 3 + xvfmina.d VM1, x1, x2 + xvfmina.d VM2, x3, x4 + xvfmina.d VM0, VM1, VM2 + .align 3 + +.L12: //INCX==1 and N<8 + andi I, N, 7 + li.d J, 4 + bge J, I, .L13 // 4 Date: Thu, 7 Dec 2023 11:30:02 +0800 Subject: [PATCH 46/60] loongarch64: Add optimization for max. --- kernel/loongarch64/KERNEL.LOONGSON2K1000 | 3 + kernel/loongarch64/KERNEL.LOONGSON3R5 | 3 + kernel/loongarch64/dmax_lasx.S | 175 +++++++++++++++++++ kernel/loongarch64/dmax_lsx.S | 141 ++++++++++++++++ kernel/loongarch64/smax_lasx.S | 205 +++++++++++++++++++++++ kernel/loongarch64/smax_lsx.S | 171 +++++++++++++++++++ 6 files changed, 698 insertions(+) create mode 100644 kernel/loongarch64/dmax_lasx.S create mode 100644 kernel/loongarch64/dmax_lsx.S create mode 100644 kernel/loongarch64/smax_lasx.S create mode 100644 kernel/loongarch64/smax_lsx.S diff --git a/kernel/loongarch64/KERNEL.LOONGSON2K1000 b/kernel/loongarch64/KERNEL.LOONGSON2K1000 index 279ff6a9c..e00893b72 100644 --- a/kernel/loongarch64/KERNEL.LOONGSON2K1000 +++ b/kernel/loongarch64/KERNEL.LOONGSON2K1000 @@ -13,4 +13,7 @@ DAMAXKERNEL = damax_lsx.S SAMINKERNEL = samin_lsx.S DAMINKERNEL = damin_lsx.S +SMAXKERNEL = smax_lsx.S +DMAXKERNEL = dmax_lsx.S + endif diff --git a/kernel/loongarch64/KERNEL.LOONGSON3R5 b/kernel/loongarch64/KERNEL.LOONGSON3R5 index 83db79050..f238436f5 100644 --- a/kernel/loongarch64/KERNEL.LOONGSON3R5 +++ b/kernel/loongarch64/KERNEL.LOONGSON3R5 @@ -13,6 +13,9 @@ DAMAXKERNEL = damax_lasx.S SAMINKERNEL = samin_lasx.S DAMINKERNEL = damin_lasx.S +SMAXKERNEL = smax_lasx.S +DMAXKERNEL = dmax_lasx.S + DGEMMKERNEL = dgemm_kernel_16x4.S DGEMMINCOPY = dgemm_ncopy_16.S DGEMMITCOPY = dgemm_tcopy_16.S diff --git a/kernel/loongarch64/dmax_lasx.S b/kernel/loongarch64/dmax_lasx.S new file mode 100644 index 000000000..46366d2ec --- /dev/null +++ b/kernel/loongarch64/dmax_lasx.S @@ -0,0 +1,175 @@ +#define ASSEMBLER + +#include "common.h" + +#define N $r4 +#define X $r5 +#define INCX $r6 +#define I $r12 +#define J $r13 +#define t1 $r14 +#define t2 $r18 +#define t3 $r15 +#define t4 $r17 +#define TEMP $r16 +#define m0 $xr8 +#define x1 $xr9 +#define x2 $xr10 +#define x3 $xr11 +#define x4 $xr12 +#define VX0 $xr20 +#define VX1 $xr21 +#define VM0 $xr22 +#define VM1 $xr23 +#define VM2 $xr19 + + PROLOGUE + + bge $r0, N, .L999 + bge $r0, INCX, .L999 + li.d TEMP, 1 + slli.d TEMP, TEMP, BASE_SHIFT + slli.d INCX, INCX, BASE_SHIFT + bne INCX, TEMP, .L20 + xvld VM0, X, 0 + srai.d I, N, 3 + bge $r0, I, .L12 + .align 3 + +.L10: + xvld VX0, X, 0 * SIZE + xvld VX1, X, 4 * SIZE + addi.d I, I, -1 + xvfmax.d VM1, VX1, VX0 + addi.d X, X, 8 * SIZE + xvfmax.d VM0, VM0, VM1 + blt $r0, I, .L10 + .align 3 + +.L11: + xvpickve.d x1, VM0, 0 + xvpickve.d x2, VM0, 1 + xvpickve.d x3, VM0, 2 + xvpickve.d x4, VM0, 3 + xvfmax.d VM1, x1, x2 + xvfmax.d VM2, x3, x4 + xvfmax.d VM0, VM1, VM2 + .align 3 + +.L12: //INCX==1 and N<8 + andi I, N, 7 + li.d J, 4 + bge J, I, .L13 // 4 Date: Thu, 7 Dec 2023 11:51:19 +0800 Subject: [PATCH 47/60] loongarch64: Add optimization for min. --- kernel/loongarch64/KERNEL.LOONGSON2K1000 | 3 + kernel/loongarch64/KERNEL.LOONGSON3R5 | 3 + kernel/loongarch64/dmin_lasx.S | 175 +++++++++++++++++++ kernel/loongarch64/dmin_lsx.S | 143 ++++++++++++++++ kernel/loongarch64/smin_lasx.S | 205 +++++++++++++++++++++++ kernel/loongarch64/smin_lsx.S | 174 +++++++++++++++++++ 6 files changed, 703 insertions(+) create mode 100644 kernel/loongarch64/dmin_lasx.S create mode 100644 kernel/loongarch64/dmin_lsx.S create mode 100644 kernel/loongarch64/smin_lasx.S create mode 100644 kernel/loongarch64/smin_lsx.S diff --git a/kernel/loongarch64/KERNEL.LOONGSON2K1000 b/kernel/loongarch64/KERNEL.LOONGSON2K1000 index e00893b72..0ff73c2db 100644 --- a/kernel/loongarch64/KERNEL.LOONGSON2K1000 +++ b/kernel/loongarch64/KERNEL.LOONGSON2K1000 @@ -16,4 +16,7 @@ DAMINKERNEL = damin_lsx.S SMAXKERNEL = smax_lsx.S DMAXKERNEL = dmax_lsx.S +SMINKERNEL = smin_lsx.S +DMINKERNEL = dmin_lsx.S + endif diff --git a/kernel/loongarch64/KERNEL.LOONGSON3R5 b/kernel/loongarch64/KERNEL.LOONGSON3R5 index f238436f5..71f53d9d7 100644 --- a/kernel/loongarch64/KERNEL.LOONGSON3R5 +++ b/kernel/loongarch64/KERNEL.LOONGSON3R5 @@ -16,6 +16,9 @@ DAMINKERNEL = damin_lasx.S SMAXKERNEL = smax_lasx.S DMAXKERNEL = dmax_lasx.S +SMINKERNEL = smin_lasx.S +DMINKERNEL = dmin_lasx.S + DGEMMKERNEL = dgemm_kernel_16x4.S DGEMMINCOPY = dgemm_ncopy_16.S DGEMMITCOPY = dgemm_tcopy_16.S diff --git a/kernel/loongarch64/dmin_lasx.S b/kernel/loongarch64/dmin_lasx.S new file mode 100644 index 000000000..e76056565 --- /dev/null +++ b/kernel/loongarch64/dmin_lasx.S @@ -0,0 +1,175 @@ +#define ASSEMBLER + +#include "common.h" + +#define N $r4 +#define X $r5 +#define INCX $r6 +#define I $r12 +#define J $r13 +#define t1 $r14 +#define t2 $r18 +#define t3 $r15 +#define t4 $r17 +#define TEMP $r16 +#define m0 $xr8 +#define x1 $xr9 +#define x2 $xr10 +#define x3 $xr11 +#define x4 $xr12 +#define VX0 $xr20 +#define VX1 $xr21 +#define VM0 $xr22 +#define VM1 $xr23 +#define VM2 $xr19 + + PROLOGUE + + bge $r0, N, .L999 + bge $r0, INCX, .L999 + li.d TEMP, 1 + slli.d TEMP, TEMP, BASE_SHIFT + slli.d INCX, INCX, BASE_SHIFT + bne INCX, TEMP, .L20 + xvld VM0, X, 0 + srai.d I, N, 3 + bge $r0, I, .L12 + .align 3 + +.L10: + xvld VX0, X, 0 * SIZE + xvld VX1, X, 4 * SIZE + addi.d I, I, -1 + xvfmin.d VM1, VX1, VX0 + addi.d X, X, 8 * SIZE + xvfmin.d VM0, VM0, VM1 + blt $r0, I, .L10 + .align 3 + +.L11: + xvpickve.d x1, VM0, 0 + xvpickve.d x2, VM0, 1 + xvpickve.d x3, VM0, 2 + xvpickve.d x4, VM0, 3 + xvfmin.d VM1, x1, x2 + xvfmin.d VM2, x3, x4 + xvfmin.d VM0, VM1, VM2 + .align 3 + +.L12: //INCX==1 and N<8 + andi I, N, 7 + li.d J, 4 + bge J, I, .L13 // 4 Date: Thu, 7 Dec 2023 11:56:41 +0800 Subject: [PATCH 48/60] loongarch64: Add optimizations for imax. --- kernel/loongarch64/KERNEL.LOONGSON2K1000 | 3 + kernel/loongarch64/KERNEL.LOONGSON3R5 | 3 + kernel/loongarch64/idmax_lasx.S | 273 +++++++++++++++++ kernel/loongarch64/idmax_lsx.S | 225 ++++++++++++++ kernel/loongarch64/ismax_lasx.S | 375 +++++++++++++++++++++++ kernel/loongarch64/ismax_lsx.S | 272 ++++++++++++++++ 6 files changed, 1151 insertions(+) create mode 100644 kernel/loongarch64/idmax_lasx.S create mode 100644 kernel/loongarch64/idmax_lsx.S create mode 100644 kernel/loongarch64/ismax_lasx.S create mode 100644 kernel/loongarch64/ismax_lsx.S diff --git a/kernel/loongarch64/KERNEL.LOONGSON2K1000 b/kernel/loongarch64/KERNEL.LOONGSON2K1000 index 0ff73c2db..3c201ad89 100644 --- a/kernel/loongarch64/KERNEL.LOONGSON2K1000 +++ b/kernel/loongarch64/KERNEL.LOONGSON2K1000 @@ -19,4 +19,7 @@ DMAXKERNEL = dmax_lsx.S SMINKERNEL = smin_lsx.S DMINKERNEL = dmin_lsx.S +ISMAXKERNEL = ismax_lsx.S +IDMAXKERNEL = idmax_lsx.S + endif diff --git a/kernel/loongarch64/KERNEL.LOONGSON3R5 b/kernel/loongarch64/KERNEL.LOONGSON3R5 index 71f53d9d7..953793b9a 100644 --- a/kernel/loongarch64/KERNEL.LOONGSON3R5 +++ b/kernel/loongarch64/KERNEL.LOONGSON3R5 @@ -19,6 +19,9 @@ DMAXKERNEL = dmax_lasx.S SMINKERNEL = smin_lasx.S DMINKERNEL = dmin_lasx.S +ISMAXKERNEL = ismax_lasx.S +IDMAXKERNEL = idmax_lasx.S + DGEMMKERNEL = dgemm_kernel_16x4.S DGEMMINCOPY = dgemm_ncopy_16.S DGEMMITCOPY = dgemm_tcopy_16.S diff --git a/kernel/loongarch64/idmax_lasx.S b/kernel/loongarch64/idmax_lasx.S new file mode 100644 index 000000000..bbfe0941a --- /dev/null +++ b/kernel/loongarch64/idmax_lasx.S @@ -0,0 +1,273 @@ +#define ASSEMBLER + +#include "common.h" + +#define N $r4 +#define X $r5 +#define INCX $r6 +#define I $r12 +#define t1 $r13 +#define t2 $r15 +#define t3 $r18 +#define t4 $r16 +#define i0 $r17 +#define i1 $r14 +#define TEMP $r19 +#define x1 $xr9 +#define x2 $xr10 +#define x3 $xr11 +#define x4 $xr12 +#define VX0 $xr13 +#define VX1 $xr14 +#define VM0 $xr15 +#define VM1 $xr16 +#define VINC4 $xr17 +#define VINC8 $xr18 +#define VI0 $xr20 +#define VI1 $xr21 +#define VI2 $xr22 +#define VI3 $xr8 +#define VI4 $xr19 +#define VT0 $xr23 + + PROLOGUE + li.d i0, 0 + bge $r0, N, .L999 + bge $r0, INCX, .L999 + li.d TEMP, 1 + slli.d TEMP, TEMP, BASE_SHIFT + slli.d INCX, INCX, BASE_SHIFT + bne INCX, TEMP, .L20 + xvld VM0, X, 0 + addi.d i0, i0, 1 + srai.d I, N, 3 + bge $r0, I, .L21 + slli.d i0, i0, 2 //4 + xvreplgr2vr.d VINC4, i0 + slli.d i0, i0, 1 //8 + xvreplgr2vr.d VINC8, i0 + addi.d i0, i0, -15 + xvinsgr2vr.d VI1, i0, 0 //initialize the index value for vectorization + addi.d i0, i0, 1 + xvinsgr2vr.d VI1, i0, 1 + addi.d i0, i0, 1 + xvinsgr2vr.d VI1, i0, 2 + addi.d i0, i0, 1 + xvinsgr2vr.d VI1, i0, 3 + addi.d i0, i0, 5 + xvinsgr2vr.d VI0, i0, 0 //1 + addi.d i0, i0, 1 + xvinsgr2vr.d VI0, i0, 1 //2 + addi.d i0, i0, 1 + xvinsgr2vr.d VI0, i0, 2 //3 + addi.d i0, i0, 1 + xvinsgr2vr.d VI0, i0, 3 //4 + .align 3 + +.L10: + xvld VX0, X, 0 * SIZE + xvadd.d VI1, VI1, VINC8 + xvld VX1, X, 4 * SIZE + xvadd.d VI2, VI1, VINC4 + xvfcmp.clt.d VT0, VX0, VX1 + addi.d I, I, -1 + xvbitsel.v VM1, VX0, VX1, VT0 + xvbitsel.v VI2, VI1, VI2, VT0 + xvfcmp.clt.d VT0, VM0, VM1 + addi.d X, X, 8 * SIZE + xvbitsel.v VM0, VM0, VM1, VT0 + xvbitsel.v VI0, VI0, VI2, VT0 + blt $r0, I, .L10 + .align 3 + +.L15: + xvpickve.d VI1, VI0, 0 + xvpickve.d VI2, VI0, 1 + xvpickve.d VI3, VI0, 2 + xvpickve.d VI4, VI0, 3 + xvpickve.d x1, VM0, 0 + xvpickve.d x2, VM0, 1 + xvpickve.d x3, VM0, 2 + xvpickve.d x4, VM0, 3 + xvfcmp.clt.d VT0, x1, x2 + xvbitsel.v VM1, x1, x2, VT0 + xvbitsel.v VINC4, VI1, VI2, VT0 + xvfcmp.clt.d VT0, x3, x4 + xvbitsel.v VM0, x3, x4, VT0 + xvbitsel.v VINC8, VI3, VI4, VT0 + xvfcmp.clt.d VT0, VM0, VM1 + xvbitsel.v VM0, VM0, VM1, VT0 + xvbitsel.v VI0, VINC8, VINC4, VT0 + li.d TEMP, 1 //处理尾数相等时取最小序号 + movgr2fr.d $f17, TEMP + ffint.d.l $f17, $f17 + xvfcmp.ceq.d VT0, VM0, x1 + fcmp.ceq.d $fcc0, $f23, $f17 + bceqz $fcc0, .L26 + xvfcmp.clt.d VT0, VI1, VI0 + xvbitsel.v VI0, VI0, VI1, VT0 + b .L26 + .align 3 + + +.L20: // INCX!=1 + move TEMP, X + addi.d i0, i0, 1 + ld.d t1, TEMP, 0 * SIZE + add.d TEMP, TEMP, INCX + xvinsgr2vr.d VM0, t1, 0 + srai.d I, N, 3 + bge $r0, I, .L21 + ld.d t2, TEMP, 0 * SIZE + add.d TEMP, TEMP, INCX + ld.d t3, TEMP, 0 * SIZE + add.d TEMP, TEMP, INCX + ld.d t4, TEMP, 0 * SIZE + add.d TEMP, TEMP, INCX + xvinsgr2vr.d VM0, t2, 1 + xvinsgr2vr.d VM0, t3, 2 + xvinsgr2vr.d VM0, t4, 3 + slli.d i0, i0, 2 //4 + xvreplgr2vr.d VINC4, i0 + slli.d i0, i0, 1 //8 + xvreplgr2vr.d VINC8, i0 + addi.d i0, i0, -15 + xvinsgr2vr.d VI1, i0, 0 //initialize the index value for vectorization + addi.d i0, i0, 1 + xvinsgr2vr.d VI1, i0, 1 + addi.d i0, i0, 1 + xvinsgr2vr.d VI1, i0, 2 + addi.d i0, i0, 1 + xvinsgr2vr.d VI1, i0, 3 + addi.d i0, i0, 5 + xvinsgr2vr.d VI0, i0, 0 //1 + addi.d i0, i0, 1 + xvinsgr2vr.d VI0, i0, 1 //2 + addi.d i0, i0, 1 + xvinsgr2vr.d VI0, i0, 2 //3 + addi.d i0, i0, 1 + xvinsgr2vr.d VI0, i0, 3 //4 + .align 3 + +.L24: + ld.d t1, X, 0 * SIZE + add.d X, X, INCX + ld.d t2, X, 0 * SIZE + add.d X, X, INCX + ld.d t3, X, 0 * SIZE + add.d X, X, INCX + ld.d t4, X, 0 * SIZE + add.d X, X, INCX + xvinsgr2vr.d VX0, t1, 0 + xvinsgr2vr.d VX0, t2, 1 + xvinsgr2vr.d VX0, t3, 2 + xvinsgr2vr.d VX0, t4, 3 + xvadd.d VI1, VI1, VINC8 + ld.d t1, X, 0 * SIZE + add.d X, X, INCX + ld.d t2, X, 0 * SIZE + add.d X, X, INCX + ld.d t3, X, 0 * SIZE + add.d X, X, INCX + ld.d t4, X, 0 * SIZE + add.d X, X, INCX + xvinsgr2vr.d VX1, t1, 0 + xvinsgr2vr.d VX1, t2, 1 + xvinsgr2vr.d VX1, t3, 2 + xvinsgr2vr.d VX1, t4, 3 + xvadd.d VI2, VI1, VINC4 + xvfcmp.clt.d VT0, VX0, VX1 + addi.d I, I, -1 + xvbitsel.v VM1, VX0, VX1, VT0 + xvbitsel.v VI2, VI1, VI2, VT0 + xvfcmp.clt.d VT0, VM0, VM1 + xvbitsel.v VM0, VM0, VM1, VT0 + xvbitsel.v VI0, VI0, VI2, VT0 + blt $r0, I, .L24 + .align 3 + +.L25: + xvpickve.d VI1, VI0, 0 + xvpickve.d VI2, VI0, 1 + xvpickve.d VI3, VI0, 2 + xvpickve.d VI4, VI0, 3 + xvpickve.d x1, VM0, 0 + xvpickve.d x2, VM0, 1 + xvpickve.d x3, VM0, 2 + xvpickve.d x4, VM0, 3 + xvfcmp.clt.d VT0, x1, x2 + xvbitsel.v VM1, x1, x2, VT0 + xvbitsel.v VINC4, VI1, VI2, VT0 + xvfcmp.clt.d VT0, x3, x4 + xvbitsel.v VM0, x3, x4, VT0 + xvbitsel.v VINC8, VI3, VI4, VT0 + xvfcmp.clt.d VT0, VM0, VM1 + xvbitsel.v VM0, VM0, VM1, VT0 + xvbitsel.v VI0, VINC8, VINC4, VT0 + li.d TEMP, 1 //处理尾数相等时取最小序号 + movgr2fr.d $f17, TEMP + ffint.d.l $f17, $f17 + xvfcmp.ceq.d VT0, VM0, x1 + fcmp.ceq.d $fcc0, $f23, $f17 + bceqz $fcc0, .L26 + xvfcmp.clt.d VT0, VI1, VI0 + xvbitsel.v VI0, VI0, VI1, VT0 + .align 3 + +.L26: + xvfcmp.ceq.d VT0, VM0, x2 + fcmp.ceq.d $fcc0, $f23, $f17 + bceqz $fcc0, .L27 + xvfcmp.clt.d VT0, VI2, VI0 + xvbitsel.v VI0, VI0, VI2, VT0 + .align 3 + +.L27: + xvfcmp.ceq.d VT0, VM0, x3 + fcmp.ceq.d $fcc0, $f23, $f17 + bceqz $fcc0, .L28 + xvfcmp.clt.d VT0, VI3, VI0 + xvbitsel.v VI0, VI0, VI3, VT0 + .align 3 + +.L28: + xvfcmp.ceq.d VT0, VM0, x4 + fcmp.ceq.d $fcc0, $f23, $f17 + bceqz $fcc0, .L29 + xvfcmp.clt.d VT0, VI4, VI0 + xvbitsel.v VI0, VI0, VI4, VT0 + .align 3 + +.L29: + movfr2gr.d i0, $f20 + .align 3 + +.L21: //N<8 + andi I, N, 7 + bge $r0, I, .L999 + srai.d i1, N, 3 + slli.d i1, i1, 3 + addi.d i1, i1, 1 //current index + movgr2fr.d $f21, i1 + movgr2fr.d $f20, i0 + .align 3 + +.L22: + fld.d $f9, X, 0 + addi.d I, I, -1 + fcmp.clt.d $fcc0, $f15, $f9 + add.d X, X, INCX + fsel $f15, $f15, $f9, $fcc0 + fsel $f20, $f20, $f21, $fcc0 + addi.d i1, i1, 1 + movgr2fr.d $f21, i1 + blt $r0, I, .L22 + movfr2gr.d i0, $f20 + .align 3 + +.L999: + move $r4, $r17 + jirl $r0, $r1, 0x0 + .align 3 + + EPILOGUE \ No newline at end of file diff --git a/kernel/loongarch64/idmax_lsx.S b/kernel/loongarch64/idmax_lsx.S new file mode 100644 index 000000000..1b4734bab --- /dev/null +++ b/kernel/loongarch64/idmax_lsx.S @@ -0,0 +1,225 @@ +#define ASSEMBLER + +#include "common.h" + +#define N $r4 +#define X $r5 +#define INCX $r6 +#define I $r12 +#define t1 $r13 +#define t2 $r15 +#define t3 $r18 +#define t4 $r16 +#define i0 $r17 +#define i1 $r14 +#define TEMP $r19 +#define x1 $vr9 +#define x2 $vr10 +#define x3 $vr11 +#define x4 $vr12 +#define VX0 $vr13 +#define VX1 $vr14 +#define VM0 $vr15 +#define VM1 $vr16 +#define VINC2 $vr17 +#define VINC4 $vr18 +#define VI0 $vr20 +#define VI1 $vr21 +#define VI2 $vr22 +#define VI3 $vr8 +#define VI4 $vr19 +#define VT0 $vr23 + + PROLOGUE + li.d i0, 0 + bge $r0, N, .L999 + bge $r0, INCX, .L999 + li.d TEMP, 1 + slli.d TEMP, TEMP, BASE_SHIFT + slli.d INCX, INCX, BASE_SHIFT + bne INCX, TEMP, .L20 + vld VM0, X, 0 + addi.d i0, i0, 1 + srai.d I, N, 3 + bge $r0, I, .L21 + slli.d i0, i0, 1 //2 + vreplgr2vr.d VINC2, i0 + slli.d i0, i0, 1 //4 + vreplgr2vr.d VINC4, i0 + addi.d i0, i0, -7 + vinsgr2vr.d VI1, i0, 0 //initialize the index value for vectorization + addi.d i0, i0, 1 + vinsgr2vr.d VI1, i0, 1 + addi.d i0, i0, 3 + vinsgr2vr.d VI0, i0, 0 //1 + addi.d i0, i0, 1 + vinsgr2vr.d VI0, i0, 1 //2 + .align 3 + +.L10: + vld VX0, X, 0 * SIZE + vadd.d VI1, VI1, VINC4 + vld VX1, X, 2 * SIZE + vadd.d VI2, VI1, VINC2 + vfcmp.clt.d VT0, VX0, VX1 + vbitsel.v x1, VX0, VX1, VT0 + vbitsel.v x2, VI1, VI2, VT0 + vld VX0, X, 4 * SIZE + vadd.d VI1, VI2, VINC2 + vld VX1, X, 6 * SIZE + vadd.d VI2, VI1, VINC2 + vfcmp.clt.d VT0, VX0, VX1 + addi.d I, I, -1 + vbitsel.v x3, VX0, VX1, VT0 + vbitsel.v x4, VI1, VI2, VT0 + vfcmp.clt.d VT0, x1, x3 + vbitsel.v x1, x1, x3, VT0 + vbitsel.v x2, x2, x4, VT0 + vfcmp.clt.d VT0, VM0, x1 + addi.d X, X, 8 * SIZE + vbitsel.v VM0, VM0, x1, VT0 + vbitsel.v VI0, VI0, x2, VT0 + blt $r0, I, .L10 + .align 3 + +.L15: + vreplvei.d VI1, VI0, 0 + vreplvei.d VI2, VI0, 1 + vreplvei.d x1, VM0, 0 + vreplvei.d x2, VM0, 1 + li.d TEMP, 1 //处理尾数相等时取最小序号 + movgr2fr.d $f17, TEMP + ffint.d.l $f17, $f17 + vfcmp.ceq.d VT0, x2, x1 + fcmp.ceq.d $fcc0, $f23, $f17 + bceqz $fcc0, .L26 + vfcmp.clt.d VT0, VI1, VI0 + vbitsel.v VI0, VI0, VI1, VT0 + b .L27 + .align 3 + +.L20: // INCX!=1 + move TEMP, X + addi.d i0, i0, 1 + ld.d t1, TEMP, 0 * SIZE + add.d TEMP, TEMP, INCX + vinsgr2vr.d VM0, t1, 0 + srai.d I, N, 3 + bge $r0, I, .L21 + ld.d t2, TEMP, 0 * SIZE + add.d TEMP, TEMP, INCX + vinsgr2vr.d VM0, t2, 1 + slli.d i0, i0, 1 //2 + vreplgr2vr.d VINC2, i0 + slli.d i0, i0, 1 //4 + vreplgr2vr.d VINC4, i0 + addi.d i0, i0, -7 + vinsgr2vr.d VI1, i0, 0 //initialize the index value for vectorization + addi.d i0, i0, 1 + vinsgr2vr.d VI1, i0, 1 + addi.d i0, i0, 3 + vinsgr2vr.d VI0, i0, 0 //1 + addi.d i0, i0, 1 + vinsgr2vr.d VI0, i0, 1 //2 + .align 3 + +.L24: + ld.d t1, X, 0 * SIZE + add.d X, X, INCX + ld.d t2, X, 0 * SIZE + add.d X, X, INCX + vinsgr2vr.d VX0, t1, 0 + vinsgr2vr.d VX0, t2, 1 + vadd.d VI1, VI1, VINC4 + ld.d t1, X, 0 * SIZE + add.d X, X, INCX + ld.d t2, X, 0 * SIZE + add.d X, X, INCX + vinsgr2vr.d VX1, t1, 0 + vinsgr2vr.d VX1, t2, 1 + vadd.d VI2, VI1, VINC2 + vfcmp.clt.d VT0, VX0, VX1 + vbitsel.v x1, VX0, VX1, VT0 + vbitsel.v x2, VI1, VI2, VT0 + ld.d t1, X, 0 * SIZE + add.d X, X, INCX + ld.d t2, X, 0 * SIZE + add.d X, X, INCX + vinsgr2vr.d VX0, t1, 0 + vinsgr2vr.d VX0, t2, 1 + vadd.d VI1, VI2, VINC2 + ld.d t1, X, 0 * SIZE + add.d X, X, INCX + ld.d t2, X, 0 * SIZE + add.d X, X, INCX + vinsgr2vr.d VX1, t1, 0 + vinsgr2vr.d VX1, t2, 1 + vadd.d VI2, VI1, VINC2 + vfcmp.clt.d VT0, VX0, VX1 + vbitsel.v x3, VX0, VX1, VT0 + vbitsel.v x4, VI1, VI2, VT0 + vfcmp.clt.d VT0, x1, x3 + vbitsel.v x1, x1, x3, VT0 + vbitsel.v x2, x2, x4, VT0 + vfcmp.clt.d VT0, VM0, x1 + addi.d I, I, -1 + vbitsel.v VM0, VM0, x1, VT0 + vbitsel.v VI0, VI0, x2, VT0 + blt $r0, I, .L24 + .align 3 + +.L25: + vreplvei.d VI1, VI0, 0 + vreplvei.d VI2, VI0, 1 + vreplvei.d x1, VM0, 0 + vreplvei.d x2, VM0, 1 + li.d TEMP, 1 //处理尾数相等时取最小序号 + movgr2fr.d $f17, TEMP + ffint.d.l $f17, $f17 + vfcmp.ceq.d VT0, x2, x1 + fcmp.ceq.d $fcc0, $f23, $f17 + bceqz $fcc0, .L26 + vfcmp.clt.d VT0, VI1, VI0 + vbitsel.v VI0, VI0, VI1, VT0 + b .L27 + .align 3 + +.L26: + vfcmp.clt.d VT0, x1, x2 + vbitsel.v VM0, x1, x2, VT0 + vbitsel.v VI0, VI1, VI2, VT0 + .align 3 + +.L27: + movfr2gr.d i0, $f20 + .align 3 + +.L21: //N<8 + andi I, N, 7 + bge $r0, I, .L999 + srai.d i1, N, 3 + slli.d i1, i1, 3 + addi.d i1, i1, 1 //current index + movgr2fr.d $f21, i1 + movgr2fr.d $f20, i0 + .align 3 + +.L22: + fld.d $f9, X, 0 + addi.d I, I, -1 + fcmp.clt.d $fcc0, $f15, $f9 + add.d X, X, INCX + fsel $f15, $f15, $f9, $fcc0 + fsel $f20, $f20, $f21, $fcc0 + addi.d i1, i1, 1 + movgr2fr.d $f21, i1 + blt $r0, I, .L22 + movfr2gr.d i0, $f20 + .align 3 + +.L999: + move $r4, $r17 + jirl $r0, $r1, 0x0 + .align 3 + + EPILOGUE \ No newline at end of file diff --git a/kernel/loongarch64/ismax_lasx.S b/kernel/loongarch64/ismax_lasx.S new file mode 100644 index 000000000..843dd6c6a --- /dev/null +++ b/kernel/loongarch64/ismax_lasx.S @@ -0,0 +1,375 @@ +#define ASSEMBLER + +#include "common.h" + +#define N $r4 +#define X $r5 +#define INCX $r6 +#define I $r12 +#define t1 $r13 +#define t2 $r15 +#define t3 $r18 +#define t4 $r16 +#define i0 $r17 +#define i1 $r14 +#define TEMP $r19 +#define x1 $xr9 +#define x2 $xr10 +#define x3 $xr11 +#define x4 $xr12 +#define VX0 $xr13 +#define VX1 $xr14 +#define VM0 $xr15 +#define VM1 $xr16 +#define VINC4 $xr17 +#define VINC8 $xr18 +#define VI0 $xr20 +#define VI1 $xr21 +#define VI2 $xr22 +#define VI3 $xr8 +#define VI4 $xr19 +#define VT0 $xr23 + + PROLOGUE + li.d i0, 0 + bge $r0, N, .L999 + bge $r0, INCX, .L999 + li.d TEMP, 1 + slli.d TEMP, TEMP, BASE_SHIFT + slli.d INCX, INCX, BASE_SHIFT + bne INCX, TEMP, .L20 + xvld VM0, X, 0 + addi.w i0, i0, 1 + srai.d I, N, 3 + bge $r0, I, .L21 + slli.w i0, i0, 3 //8 + xvreplgr2vr.w VINC8, i0 + addi.w i0, i0, -15 + xvinsgr2vr.w VI1, i0, 0 //initialize the index value for vectorization + addi.w i0, i0, 1 + xvinsgr2vr.w VI1, i0, 1 + addi.w i0, i0, 1 + xvinsgr2vr.w VI1, i0, 2 + addi.w i0, i0, 1 + xvinsgr2vr.w VI1, i0, 3 + addi.w i0, i0, 1 + xvinsgr2vr.w VI1, i0, 4 + addi.w i0, i0, 1 + xvinsgr2vr.w VI1, i0, 5 + addi.w i0, i0, 1 + xvinsgr2vr.w VI1, i0, 6 + addi.w i0, i0, 1 + xvinsgr2vr.w VI1, i0, 7 + addi.w i0, i0, 1 + xvinsgr2vr.w VI0, i0, 0 //1 + addi.w i0, i0, 1 + xvinsgr2vr.w VI0, i0, 1 //2 + addi.w i0, i0, 1 + xvinsgr2vr.w VI0, i0, 2 //3 + addi.w i0, i0, 1 + xvinsgr2vr.w VI0, i0, 3 //4 + addi.w i0, i0, 1 + xvinsgr2vr.w VI0, i0, 4 //5 + addi.w i0, i0, 1 + xvinsgr2vr.w VI0, i0, 5 //6 + addi.w i0, i0, 1 + xvinsgr2vr.w VI0, i0, 6 //7 + addi.w i0, i0, 1 + xvinsgr2vr.w VI0, i0, 7 //8 + .align 3 + +.L10: + xvld VX0, X, 0 * SIZE + xvadd.w VI1, VI1, VINC8 + xvfcmp.clt.s VT0, VM0, VX0 + addi.d I, I, -1 + xvbitsel.v VM0, VM0, VX0, VT0 + xvbitsel.v VI0, VI0, VI1, VT0 + addi.d X, X, 8 * SIZE + blt $r0, I, .L10 + .align 3 + +.L15: + xvxor.v VX0, VX0, VX0 + xvor.v VX0, VI0, VX0 + xvxor.v VX1, VX1, VX1 + xvor.v VX1, VM0, VX1 + xvpickve.w VI1, VI0, 0 + xvpickve.w VI2, VI0, 1 + xvpickve.w VI3, VI0, 2 + xvpickve.w VI4, VI0, 3 + xvpickve.w x1, VM0, 0 + xvpickve.w x2, VM0, 1 + xvpickve.w x3, VM0, 2 + xvpickve.w x4, VM0, 3 + xvfcmp.clt.s VT0, x1, x2 + xvbitsel.v VM1, x1, x2, VT0 + xvbitsel.v VINC4, VI1, VI2, VT0 + xvfcmp.clt.s VT0, x3, x4 + xvbitsel.v VM0, x3, x4, VT0 + xvbitsel.v VINC8, VI3, VI4, VT0 + xvfcmp.clt.s VT0, VM0, VM1 + xvbitsel.v VM0, VM0, VM1, VT0 + xvbitsel.v VI0, VINC8, VINC4, VT0 + li.d TEMP, 1 //处理尾数相等时取最小序号 + movgr2fr.w $f17, TEMP + ffint.s.w $f17, $f17 + xvfcmp.ceq.s VT0, VM0, x1 + fcmp.ceq.s $fcc0, $f23, $f17 + bceqz $fcc0, .L26 + xvfcmp.clt.s VT0, VI1, VI0 + xvbitsel.v VI0, VI0, VI1, VT0 + b .L26 + .align 3 + + +.L20: // INCX!=1 + move TEMP, X + addi.w i0, i0, 1 + ld.w t1, TEMP, 0 * SIZE + add.d TEMP, TEMP, INCX + srai.d I, N, 3 + bge $r0, I, .L21 + ld.w t2, TEMP, 0 * SIZE + add.d TEMP, TEMP, INCX + ld.w t3, TEMP, 0 * SIZE + add.d TEMP, TEMP, INCX + ld.w t4, TEMP, 0 * SIZE + add.d TEMP, TEMP, INCX + xvinsgr2vr.w VM0, t1, 0 + xvinsgr2vr.w VM0, t2, 1 + xvinsgr2vr.w VM0, t3, 2 + xvinsgr2vr.w VM0, t4, 3 + ld.w t1, TEMP, 0 * SIZE + add.d TEMP, TEMP, INCX + ld.w t2, TEMP, 0 * SIZE + add.d TEMP, TEMP, INCX + ld.w t3, TEMP, 0 * SIZE + add.d TEMP, TEMP, INCX + ld.w t4, TEMP, 0 * SIZE + add.d TEMP, TEMP, INCX + xvinsgr2vr.w VM0, t1, 4 + xvinsgr2vr.w VM0, t2, 5 + xvinsgr2vr.w VM0, t3, 6 + xvinsgr2vr.w VM0, t4, 7 + slli.w i0, i0, 3 //8 + xvreplgr2vr.w VINC8, i0 + addi.w i0, i0, -15 + xvinsgr2vr.w VI1, i0, 0 //initialize the index value for vectorization + addi.w i0, i0, 1 + xvinsgr2vr.w VI1, i0, 1 + addi.w i0, i0, 1 + xvinsgr2vr.w VI1, i0, 2 + addi.w i0, i0, 1 + xvinsgr2vr.w VI1, i0, 3 + addi.w i0, i0, 1 + xvinsgr2vr.w VI1, i0, 4 + addi.w i0, i0, 1 + xvinsgr2vr.w VI1, i0, 5 + addi.w i0, i0, 1 + xvinsgr2vr.w VI1, i0, 6 + addi.w i0, i0, 1 + xvinsgr2vr.w VI1, i0, 7 + addi.w i0, i0, 1 + xvinsgr2vr.w VI0, i0, 0 //1 + addi.w i0, i0, 1 + xvinsgr2vr.w VI0, i0, 1 //2 + addi.w i0, i0, 1 + xvinsgr2vr.w VI0, i0, 2 //3 + addi.w i0, i0, 1 + xvinsgr2vr.w VI0, i0, 3 //4 + addi.w i0, i0, 1 + xvinsgr2vr.w VI0, i0, 4 //5 + addi.w i0, i0, 1 + xvinsgr2vr.w VI0, i0, 5 //6 + addi.w i0, i0, 1 + xvinsgr2vr.w VI0, i0, 6 //7 + addi.w i0, i0, 1 + xvinsgr2vr.w VI0, i0, 7 //8 + .align 3 + +.L24: + ld.w t1, X, 0 * SIZE + add.d X, X, INCX + ld.w t2, X, 0 * SIZE + add.d X, X, INCX + ld.w t3, X, 0 * SIZE + add.d X, X, INCX + ld.w t4, X, 0 * SIZE + add.d X, X, INCX + xvinsgr2vr.w VX0, t1, 0 + xvinsgr2vr.w VX0, t2, 1 + xvinsgr2vr.w VX0, t3, 2 + xvinsgr2vr.w VX0, t4, 3 + ld.w t1, X, 0 * SIZE + add.d X, X, INCX + ld.w t2, X, 0 * SIZE + add.d X, X, INCX + ld.w t3, X, 0 * SIZE + add.d X, X, INCX + ld.w t4, X, 0 * SIZE + add.d X, X, INCX + xvinsgr2vr.w VX0, t1, 4 + xvinsgr2vr.w VX0, t2, 5 + xvinsgr2vr.w VX0, t3, 6 + xvinsgr2vr.w VX0, t4, 7 + xvadd.w VI1, VI1, VINC8 + xvfcmp.clt.s VT0, VM0, VX0 + addi.d I, I, -1 + xvbitsel.v VM0, VM0, VX0, VT0 + xvbitsel.v VI0, VI0, VI1, VT0 + blt $r0, I, .L24 + .align 3 + +.L25: + xvxor.v VX0, VX0, VX0 + xvor.v VX0, VI0, VX0 + xvxor.v VX1, VX1, VX1 + xvor.v VX1, VM0, VX1 + xvpickve.w VI1, VI0, 0 + xvpickve.w VI2, VI0, 1 + xvpickve.w VI3, VI0, 2 + xvpickve.w VI4, VI0, 3 + xvpickve.w x1, VM0, 0 + xvpickve.w x2, VM0, 1 + xvpickve.w x3, VM0, 2 + xvpickve.w x4, VM0, 3 + xvfcmp.clt.s VT0, x1, x2 + xvbitsel.v VM1, x1, x2, VT0 + xvbitsel.v VINC4, VI1, VI2, VT0 + xvfcmp.clt.s VT0, x3, x4 + xvbitsel.v VM0, x3, x4, VT0 + xvbitsel.v VINC8, VI3, VI4, VT0 + xvfcmp.clt.s VT0, VM0, VM1 + xvbitsel.v VM0, VM0, VM1, VT0 + xvbitsel.v VI0, VINC8, VINC4, VT0 + li.d TEMP, 1 //处理尾数相等时取最小序号 + movgr2fr.w $f17, TEMP + ffint.s.w $f17, $f17 + xvfcmp.ceq.s VT0, VM0, x1 + fcmp.ceq.s $fcc0, $f23, $f17 + bceqz $fcc0, .L26 + xvfcmp.clt.s VT0, VI1, VI0 + xvbitsel.v VI0, VI0, VI1, VT0 + .align 3 + +.L26: + xvfcmp.ceq.s VT0, VM0, x2 + fcmp.ceq.s $fcc0, $f23, $f17 + bceqz $fcc0, .L27 + xvfcmp.clt.s VT0, VI2, VI0 + xvbitsel.v VI0, VI0, VI2, VT0 + .align 3 + +.L27: + xvfcmp.ceq.s VT0, VM0, x3 + fcmp.ceq.s $fcc0, $f23, $f17 + bceqz $fcc0, .L28 + xvfcmp.clt.s VT0, VI3, VI0 + xvbitsel.v VI0, VI0, VI3, VT0 + .align 3 + +.L28: + xvfcmp.ceq.s VT0, VM0, x4 + fcmp.ceq.s $fcc0, $f23, $f17 + bceqz $fcc0, .L29 + xvfcmp.clt.s VT0, VI4, VI0 + xvbitsel.v VI0, VI0, VI4, VT0 + .align 3 + +.L29: + fmov.s $f16, $f20 + .align 3 + +.L252: + xvxor.v VI0, VI0, VI0 + xvor.v VI0, VI0, VX0 + fmov.s $f13, $f15 + xvxor.v VM0, VM0, VM0 + xvor.v VM0, VM0, VX1 + xvpickve.w VI1, VI0, 4 + xvpickve.w VI2, VI0, 5 + xvpickve.w VI3, VI0, 6 + xvpickve.w VI4, VI0, 7 + xvpickve.w x1, VM0, 4 + xvpickve.w x2, VM0, 5 + xvpickve.w x3, VM0, 6 + xvpickve.w x4, VM0, 7 + xvfcmp.clt.s VT0, x1, x2 + xvbitsel.v x1, x1, x2, VT0 + xvbitsel.v VINC4, VI1, VI2, VT0 + xvfcmp.clt.s VT0, x3, x4 + xvbitsel.v VM0, x3, x4, VT0 + xvbitsel.v VINC8, VI3, VI4, VT0 + xvfcmp.clt.s VT0, VM0, x1 + xvbitsel.v VM0, VM0, x1, VT0 + xvbitsel.v VI0, VINC8, VINC4, VT0 + li.d TEMP, 1 //处理尾数相等时取最小序号 + movgr2fr.w $f17, TEMP + ffint.s.w $f17, $f17 + xvfcmp.ceq.s VT0, VM0, x1 + fcmp.ceq.s $fcc0, $f23, $f17 + bceqz $fcc0, .L262 + xvfcmp.clt.s VT0, VI1, VI0 + xvbitsel.v VI0, VI0, VI1, VT0 + .align 3 + +.L262: + xvfcmp.ceq.s VT0, VM0, x2 + fcmp.ceq.s $fcc0, $f23, $f17 + bceqz $fcc0, .L272 + xvfcmp.clt.s VT0, VI2, VI0 + xvbitsel.v VI0, VI0, VI2, VT0 + .align 3 + +.L272: + xvfcmp.ceq.s VT0, VM0, x3 + fcmp.ceq.s $fcc0, $f23, $f17 + bceqz $fcc0, .L282 + xvfcmp.clt.s VT0, VI3, VI0 + xvbitsel.v VI0, VI0, VI3, VT0 + .align 3 + +.L282: + xvfcmp.ceq.s VT0, VM0, x4 + fcmp.ceq.s $fcc0, $f23, $f17 + bceqz $fcc0, .L292 + xvfcmp.clt.s VT0, VI4, VI0 + xvbitsel.v VI0, VI0, VI4, VT0 + .align 3 + +.L292: + fcmp.clt.s $fcc0, $f15, $f13 + fsel $f15, $f15, $f13, $fcc0 + fsel $f20, $f20, $f16, $fcc0 + movfr2gr.s i0, $f20 + +.L21: //N<8 + andi I, N, 7 + bge $r0, I, .L999 + srai.d i1, N, 3 + slli.d i1, i1, 3 + addi.d i1, i1, 1 //current index + movgr2fr.d $f21, i1 + movgr2fr.d $f20, i0 + .align 3 + +.L22: + fld.d $f9, X, 0 + addi.d I, I, -1 + fcmp.clt.s $fcc0, $f15, $f9 + add.d X, X, INCX + fsel $f15, $f15, $f9, $fcc0 + fsel $f20, $f20, $f21, $fcc0 + addi.d i1, i1, 1 + movgr2fr.d $f21, i1 + blt $r0, I, .L22 + movfr2gr.s i0, $f20 + .align 3 + +.L999: + move $r4, $r17 + jirl $r0, $r1, 0x0 + .align 3 + + EPILOGUE \ No newline at end of file diff --git a/kernel/loongarch64/ismax_lsx.S b/kernel/loongarch64/ismax_lsx.S new file mode 100644 index 000000000..33b326bbd --- /dev/null +++ b/kernel/loongarch64/ismax_lsx.S @@ -0,0 +1,272 @@ +#define ASSEMBLER + +#include "common.h" + +#define N $r4 +#define X $r5 +#define INCX $r6 +#define I $r12 +#define t1 $r13 +#define t2 $r15 +#define t3 $r18 +#define t4 $r16 +#define i0 $r17 +#define i1 $r14 +#define TEMP $r19 +#define x1 $vr9 +#define x2 $vr10 +#define x3 $vr11 +#define x4 $vr12 +#define VX0 $vr13 +#define VX1 $vr14 +#define VM0 $vr15 +#define VM1 $vr16 +#define VINC4 $vr17 +#define VINC8 $vr18 +#define VI0 $vr20 +#define VI1 $vr21 +#define VI2 $vr22 +#define VI3 $vr8 +#define VI4 $vr19 +#define VT0 $vr23 + + PROLOGUE + li.d i0, 0 + bge $r0, N, .L999 + bge $r0, INCX, .L999 + li.d TEMP, 1 + slli.d TEMP, TEMP, BASE_SHIFT + slli.d INCX, INCX, BASE_SHIFT + bne INCX, TEMP, .L20 + vld VM0, X, 0 + addi.w i0, i0, 1 + srai.d I, N, 3 + bge $r0, I, .L21 + slli.w i0, i0, 2 //4 + vreplgr2vr.w VINC4, i0 + slli.w i0, i0, 1 //8 + vreplgr2vr.w VINC8, i0 + addi.w i0, i0, -15 + vinsgr2vr.w VI1, i0, 0 //initialize the index value for vectorization + addi.w i0, i0, 1 + vinsgr2vr.w VI1, i0, 1 + addi.w i0, i0, 1 + vinsgr2vr.w VI1, i0, 2 + addi.w i0, i0, 1 + vinsgr2vr.w VI1, i0, 3 + addi.w i0, i0, 5 + vinsgr2vr.w VI0, i0, 0 //1 + addi.w i0, i0, 1 + vinsgr2vr.w VI0, i0, 1 //2 + addi.w i0, i0, 1 + vinsgr2vr.w VI0, i0, 2 //3 + addi.w i0, i0, 1 + vinsgr2vr.w VI0, i0, 3 //4 + .align 3 + +.L10: + vld VX0, X, 0 * SIZE + vadd.w VI1, VI1, VINC8 + vld VX1, X, 4 * SIZE + vadd.w VI2, VI1, VINC4 + vfcmp.clt.s VT0, VX0, VX1 + addi.d I, I, -1 + vbitsel.v VM1, VX0, VX1, VT0 + vbitsel.v VI2, VI1, VI2, VT0 + vfcmp.clt.s VT0, VM0, VM1 + addi.d X, X, 8 * SIZE + vbitsel.v VM0, VM0, VM1, VT0 + vbitsel.v VI0, VI0, VI2, VT0 + blt $r0, I, .L10 + .align 3 + +.L15: + vreplvei.w VI1, VI0, 0 + vreplvei.w VI2, VI0, 1 + vreplvei.w VI3, VI0, 2 + vreplvei.w VI4, VI0, 3 + vreplvei.w x1, VM0, 0 + vreplvei.w x2, VM0, 1 + vreplvei.w x3, VM0, 2 + vreplvei.w x4, VM0, 3 + vfcmp.clt.s VT0, x1, x2 + vbitsel.v VM1, x1, x2, VT0 + vbitsel.v VINC4, VI1, VI2, VT0 + vfcmp.clt.s VT0, x3, x4 + vbitsel.v VM0, x3, x4, VT0 + vbitsel.v VINC8, VI3, VI4, VT0 + vfcmp.clt.s VT0, VM0, VM1 + vbitsel.v VM0, VM0, VM1, VT0 + vbitsel.v VI0, VINC8, VINC4, VT0 + li.d TEMP, 1 //处理尾数相等时取最小序号 + movgr2fr.w $f17, TEMP + ffint.s.w $f17, $f17 + vfcmp.ceq.s VT0, VM0, x1 + fcmp.ceq.s $fcc0, $f23, $f17 + bceqz $fcc0, .L26 + vfcmp.clt.s VT0, VI1, VI0 + vbitsel.v VI0, VI0, VI1, VT0 + b .L26 + .align 3 + +.L20: // INCX!=1 + move TEMP, X + addi.w i0, i0, 1 + ld.w t1, TEMP, 0 * SIZE + add.d TEMP, TEMP, INCX + vinsgr2vr.w VM0, t1, 0 + srai.d I, N, 3 + bge $r0, I, .L21 + ld.w t2, TEMP, 0 * SIZE + add.d TEMP, TEMP, INCX + ld.w t3, TEMP, 0 * SIZE + add.d TEMP, TEMP, INCX + ld.w t4, TEMP, 0 * SIZE + add.d TEMP, TEMP, INCX + vinsgr2vr.w VM0, t2, 1 + vinsgr2vr.w VM0, t3, 2 + vinsgr2vr.w VM0, t4, 3 + slli.w i0, i0, 2 //4 + vreplgr2vr.w VINC4, i0 + slli.w i0, i0, 1 //8 + vreplgr2vr.w VINC8, i0 + addi.w i0, i0, -15 + vinsgr2vr.w VI1, i0, 0 //initialize the index value for vectorization + addi.w i0, i0, 1 + vinsgr2vr.w VI1, i0, 1 + addi.w i0, i0, 1 + vinsgr2vr.w VI1, i0, 2 + addi.w i0, i0, 1 + vinsgr2vr.w VI1, i0, 3 + addi.w i0, i0, 5 + vinsgr2vr.w VI0, i0, 0 //1 + addi.w i0, i0, 1 + vinsgr2vr.w VI0, i0, 1 //2 + addi.w i0, i0, 1 + vinsgr2vr.w VI0, i0, 2 //3 + addi.w i0, i0, 1 + vinsgr2vr.w VI0, i0, 3 //4 + .align 3 + +.L24: + ld.w t1, X, 0 * SIZE + add.d X, X, INCX + ld.w t2, X, 0 * SIZE + add.d X, X, INCX + ld.w t3, X, 0 * SIZE + add.d X, X, INCX + ld.w t4, X, 0 * SIZE + add.d X, X, INCX + vinsgr2vr.w VX0, t1, 0 + vinsgr2vr.w VX0, t2, 1 + vinsgr2vr.w VX0, t3, 2 + vinsgr2vr.w VX0, t4, 3 + vadd.w VI1, VI1, VINC8 + ld.w t1, X, 0 * SIZE + add.d X, X, INCX + ld.w t2, X, 0 * SIZE + add.d X, X, INCX + ld.w t3, X, 0 * SIZE + add.d X, X, INCX + ld.w t4, X, 0 * SIZE + add.d X, X, INCX + vinsgr2vr.w VX1, t1, 0 + vinsgr2vr.w VX1, t2, 1 + vinsgr2vr.w VX1, t3, 2 + vinsgr2vr.w VX1, t4, 3 + vadd.w VI2, VI1, VINC4 + vfcmp.clt.s VT0, VX0, VX1 + addi.d I, I, -1 + vbitsel.v VM1, VX0, VX1, VT0 + vbitsel.v VI2, VI1, VI2, VT0 + vfcmp.clt.s VT0, VM0, VM1 + vbitsel.v VM0, VM0, VM1, VT0 + vbitsel.v VI0, VI0, VI2, VT0 + blt $r0, I, .L24 + .align 3 + +.L25: + vreplvei.w VI1, VI0, 0 + vreplvei.w VI2, VI0, 1 + vreplvei.w VI3, VI0, 2 + vreplvei.w VI4, VI0, 3 + vreplvei.w x1, VM0, 0 + vreplvei.w x2, VM0, 1 + vreplvei.w x3, VM0, 2 + vreplvei.w x4, VM0, 3 + vfcmp.clt.s VT0, x1, x2 + vbitsel.v VM1, x1, x2, VT0 + vbitsel.v VINC4, VI1, VI2, VT0 + vfcmp.clt.s VT0, x3, x4 + vbitsel.v VM0, x3, x4, VT0 + vbitsel.v VINC8, VI3, VI4, VT0 + vfcmp.clt.s VT0, VM0, VM1 + vbitsel.v VM0, VM0, VM1, VT0 + vbitsel.v VI0, VINC8, VINC4, VT0 + li.d TEMP, 1 //处理尾数相等时取最小序号 + movgr2fr.w $f17, TEMP + ffint.s.w $f17, $f17 + vfcmp.ceq.s VT0, VM0, x1 + fcmp.ceq.s $fcc0, $f23, $f17 + bceqz $fcc0, .L26 + vfcmp.clt.s VT0, VI1, VI0 + vbitsel.v VI0, VI0, VI1, VT0 + .align 3 + +.L26: + vfcmp.ceq.s VT0, VM0, x2 + fcmp.ceq.s $fcc0, $f23, $f17 + bceqz $fcc0, .L27 + vfcmp.clt.s VT0, VI2, VI0 + vbitsel.v VI0, VI0, VI2, VT0 + .align 3 + +.L27: + vfcmp.ceq.s VT0, VM0, x3 + fcmp.ceq.s $fcc0, $f23, $f17 + bceqz $fcc0, .L28 + vfcmp.clt.s VT0, VI3, VI0 + vbitsel.v VI0, VI0, VI3, VT0 + .align 3 + +.L28: + vfcmp.ceq.s VT0, VM0, x4 + fcmp.ceq.s $fcc0, $f23, $f17 + bceqz $fcc0, .L29 + vfcmp.clt.s VT0, VI4, VI0 + vbitsel.v VI0, VI0, VI4, VT0 + .align 3 + +.L29: + movfr2gr.s i0, $f20 + .align 3 + +.L21: //N<8 + andi I, N, 7 + bge $r0, I, .L999 + srai.d i1, N, 3 + slli.d i1, i1, 3 + addi.d i1, i1, 1 //current index + movgr2fr.d $f21, i1 + movgr2fr.d $f20, i0 + .align 3 + +.L22: + fld.d $f9, X, 0 + addi.d I, I, -1 + fcmp.clt.s $fcc0, $f15, $f9 + fsel $f15, $f15, $f9, $fcc0 + fsel $f20, $f20, $f21, $fcc0 + addi.d i1, i1, 1 + add.d X, X, INCX + movgr2fr.d $f21, i1 + blt $r0, I, .L22 + movfr2gr.s i0, $f20 + .align 3 + +.L999: + move $r4, $r17 + jirl $r0, $r1, 0x0 + .align 3 + + EPILOGUE \ No newline at end of file From e3fb2b5afa63fc0db472268adfd7038146ea6ac6 Mon Sep 17 00:00:00 2001 From: yancheng Date: Thu, 7 Dec 2023 12:01:05 +0800 Subject: [PATCH 49/60] loongarch64: Add optimizations for imin. --- kernel/loongarch64/KERNEL.LOONGSON2K1000 | 3 + kernel/loongarch64/KERNEL.LOONGSON3R5 | 3 + kernel/loongarch64/idmin_lasx.S | 272 +++++++++++++++++ kernel/loongarch64/idmin_lsx.S | 225 ++++++++++++++ kernel/loongarch64/ismin_lasx.S | 374 +++++++++++++++++++++++ kernel/loongarch64/ismin_lsx.S | 271 ++++++++++++++++ 6 files changed, 1148 insertions(+) create mode 100644 kernel/loongarch64/idmin_lasx.S create mode 100644 kernel/loongarch64/idmin_lsx.S create mode 100644 kernel/loongarch64/ismin_lasx.S create mode 100644 kernel/loongarch64/ismin_lsx.S diff --git a/kernel/loongarch64/KERNEL.LOONGSON2K1000 b/kernel/loongarch64/KERNEL.LOONGSON2K1000 index 3c201ad89..d0eab3d7c 100644 --- a/kernel/loongarch64/KERNEL.LOONGSON2K1000 +++ b/kernel/loongarch64/KERNEL.LOONGSON2K1000 @@ -22,4 +22,7 @@ DMINKERNEL = dmin_lsx.S ISMAXKERNEL = ismax_lsx.S IDMAXKERNEL = idmax_lsx.S +ISMINKERNEL = ismin_lsx.S +IDMINKERNEL = idmin_lsx.S + endif diff --git a/kernel/loongarch64/KERNEL.LOONGSON3R5 b/kernel/loongarch64/KERNEL.LOONGSON3R5 index 953793b9a..92389001b 100644 --- a/kernel/loongarch64/KERNEL.LOONGSON3R5 +++ b/kernel/loongarch64/KERNEL.LOONGSON3R5 @@ -22,6 +22,9 @@ DMINKERNEL = dmin_lasx.S ISMAXKERNEL = ismax_lasx.S IDMAXKERNEL = idmax_lasx.S +ISMINKERNEL = ismin_lasx.S +IDMINKERNEL = idmin_lasx.S + DGEMMKERNEL = dgemm_kernel_16x4.S DGEMMINCOPY = dgemm_ncopy_16.S DGEMMITCOPY = dgemm_tcopy_16.S diff --git a/kernel/loongarch64/idmin_lasx.S b/kernel/loongarch64/idmin_lasx.S new file mode 100644 index 000000000..7930d4963 --- /dev/null +++ b/kernel/loongarch64/idmin_lasx.S @@ -0,0 +1,272 @@ +#define ASSEMBLER + +#include "common.h" + +#define N $r4 +#define X $r5 +#define INCX $r6 +#define I $r12 +#define t1 $r13 +#define t2 $r15 +#define t3 $r18 +#define t4 $r16 +#define i0 $r17 +#define i1 $r14 +#define TEMP $r19 +#define x1 $xr9 +#define x2 $xr10 +#define x3 $xr11 +#define x4 $xr12 +#define VX0 $xr13 +#define VX1 $xr14 +#define VM0 $xr15 +#define VM1 $xr16 +#define VINC4 $xr17 +#define VINC8 $xr18 +#define VI0 $xr20 +#define VI1 $xr21 +#define VI2 $xr22 +#define VI3 $xr8 +#define VI4 $xr19 +#define VT0 $xr23 + + PROLOGUE + li.d i0, 0 + bge $r0, N, .L999 + bge $r0, INCX, .L999 + li.d TEMP, 1 + slli.d TEMP, TEMP, BASE_SHIFT + slli.d INCX, INCX, BASE_SHIFT + bne INCX, TEMP, .L20 + xvld VM0, X, 0 + addi.d i0, i0, 1 + srai.d I, N, 3 + bge $r0, I, .L21 + slli.d i0, i0, 2 //4 + xvreplgr2vr.d VINC4, i0 + slli.d i0, i0, 1 //8 + xvreplgr2vr.d VINC8, i0 + addi.d i0, i0, -15 + xvinsgr2vr.d VI1, i0, 0 //initialize the index value for vectorization + addi.d i0, i0, 1 + xvinsgr2vr.d VI1, i0, 1 + addi.d i0, i0, 1 + xvinsgr2vr.d VI1, i0, 2 + addi.d i0, i0, 1 + xvinsgr2vr.d VI1, i0, 3 + addi.d i0, i0, 5 + xvinsgr2vr.d VI0, i0, 0 //1 + addi.d i0, i0, 1 + xvinsgr2vr.d VI0, i0, 1 //2 + addi.d i0, i0, 1 + xvinsgr2vr.d VI0, i0, 2 //3 + addi.d i0, i0, 1 + xvinsgr2vr.d VI0, i0, 3 //4 + .align 3 + +.L10: + xvld VX0, X, 0 * SIZE + xvadd.d VI1, VI1, VINC8 + xvld VX1, X, 4 * SIZE + xvadd.d VI2, VI1, VINC4 + xvfcmp.clt.d VT0, VX1, VX0 + addi.d I, I, -1 + xvbitsel.v VM1, VX0, VX1, VT0 + xvbitsel.v VI2, VI1, VI2, VT0 + xvfcmp.clt.d VT0, VM1, VM0 + addi.d X, X, 8 * SIZE + xvbitsel.v VM0, VM0, VM1, VT0 + xvbitsel.v VI0, VI0, VI2, VT0 + blt $r0, I, .L10 + .align 3 + +.L15: + xvpickve.d VI1, VI0, 0 + xvpickve.d VI2, VI0, 1 + xvpickve.d VI3, VI0, 2 + xvpickve.d VI4, VI0, 3 + xvpickve.d x1, VM0, 0 + xvpickve.d x2, VM0, 1 + xvpickve.d x3, VM0, 2 + xvpickve.d x4, VM0, 3 + xvfcmp.clt.d VT0, x2, x1 + xvbitsel.v VM1, x1, x2, VT0 + xvbitsel.v VINC4, VI1, VI2, VT0 + xvfcmp.clt.d VT0, x4, x3 + xvbitsel.v VM0, x3, x4, VT0 + xvbitsel.v VINC8, VI3, VI4, VT0 + xvfcmp.clt.d VT0, VM1, VM0 + xvbitsel.v VM0, VM0, VM1, VT0 + xvbitsel.v VI0, VINC8, VINC4, VT0 + li.d TEMP, 1 //处理尾数相等时取最小序号 + movgr2fr.d $f17, TEMP + ffint.d.l $f17, $f17 + xvfcmp.ceq.d VT0, VM0, x1 + fcmp.ceq.d $fcc0, $f23, $f17 + bceqz $fcc0, .L26 + xvfcmp.clt.d VT0, VI1, VI0 + xvbitsel.v VI0, VI0, VI1, VT0 + b .L26 + .align 3 + +.L20: // INCX!=1 + move TEMP, X + addi.d i0, i0, 1 + ld.d t1, TEMP, 0 * SIZE + add.d TEMP, TEMP, INCX + xvinsgr2vr.d VM0, t1, 0 + srai.d I, N, 3 + bge $r0, I, .L21 + ld.d t2, TEMP, 0 * SIZE + add.d TEMP, TEMP, INCX + ld.d t3, TEMP, 0 * SIZE + add.d TEMP, TEMP, INCX + ld.d t4, TEMP, 0 * SIZE + add.d TEMP, TEMP, INCX + xvinsgr2vr.d VM0, t2, 1 + xvinsgr2vr.d VM0, t3, 2 + xvinsgr2vr.d VM0, t4, 3 + slli.d i0, i0, 2 //4 + xvreplgr2vr.d VINC4, i0 + slli.d i0, i0, 1 //8 + xvreplgr2vr.d VINC8, i0 + addi.d i0, i0, -15 + xvinsgr2vr.d VI1, i0, 0 //initialize the index value for vectorization + addi.d i0, i0, 1 + xvinsgr2vr.d VI1, i0, 1 + addi.d i0, i0, 1 + xvinsgr2vr.d VI1, i0, 2 + addi.d i0, i0, 1 + xvinsgr2vr.d VI1, i0, 3 + addi.d i0, i0, 5 + xvinsgr2vr.d VI0, i0, 0 //1 + addi.d i0, i0, 1 + xvinsgr2vr.d VI0, i0, 1 //2 + addi.d i0, i0, 1 + xvinsgr2vr.d VI0, i0, 2 //3 + addi.d i0, i0, 1 + xvinsgr2vr.d VI0, i0, 3 //4 + .align 3 + +.L24: + ld.d t1, X, 0 * SIZE + add.d X, X, INCX + ld.d t2, X, 0 * SIZE + add.d X, X, INCX + ld.d t3, X, 0 * SIZE + add.d X, X, INCX + ld.d t4, X, 0 * SIZE + add.d X, X, INCX + xvinsgr2vr.d VX0, t1, 0 + xvinsgr2vr.d VX0, t2, 1 + xvinsgr2vr.d VX0, t3, 2 + xvinsgr2vr.d VX0, t4, 3 + xvadd.d VI1, VI1, VINC8 + ld.d t1, X, 0 * SIZE + add.d X, X, INCX + ld.d t2, X, 0 * SIZE + add.d X, X, INCX + ld.d t3, X, 0 * SIZE + add.d X, X, INCX + ld.d t4, X, 0 * SIZE + add.d X, X, INCX + xvinsgr2vr.d VX1, t1, 0 + xvinsgr2vr.d VX1, t2, 1 + xvinsgr2vr.d VX1, t3, 2 + xvinsgr2vr.d VX1, t4, 3 + xvadd.d VI2, VI1, VINC4 + xvfcmp.clt.d VT0, VX1, VX0 + addi.d I, I, -1 + xvbitsel.v VM1, VX0, VX1, VT0 + xvbitsel.v VI2, VI1, VI2, VT0 + xvfcmp.clt.d VT0, VM1, VM0 + xvbitsel.v VM0, VM0, VM1, VT0 + xvbitsel.v VI0, VI0, VI2, VT0 + blt $r0, I, .L24 + .align 3 + +.L25: + xvpickve.d VI1, VI0, 0 + xvpickve.d VI2, VI0, 1 + xvpickve.d VI3, VI0, 2 + xvpickve.d VI4, VI0, 3 + xvpickve.d x1, VM0, 0 + xvpickve.d x2, VM0, 1 + xvpickve.d x3, VM0, 2 + xvpickve.d x4, VM0, 3 + xvfcmp.clt.d VT0, x2, x1 + xvbitsel.v VM1, x1, x2, VT0 + xvbitsel.v VINC4, VI1, VI2, VT0 + xvfcmp.clt.d VT0, x4, x3 + xvbitsel.v VM0, x3, x4, VT0 + xvbitsel.v VINC8, VI3, VI4, VT0 + xvfcmp.clt.d VT0, VM1, VM0 + xvbitsel.v VM0, VM0, VM1, VT0 + xvbitsel.v VI0, VINC8, VINC4, VT0 + li.d TEMP, 1 //处理尾数相等时取最小序号 + movgr2fr.d $f17, TEMP + ffint.d.l $f17, $f17 + xvfcmp.ceq.d VT0, VM0, x1 + fcmp.ceq.d $fcc0, $f23, $f17 + bceqz $fcc0, .L26 + xvfcmp.clt.d VT0, VI1, VI0 + xvbitsel.v VI0, VI0, VI1, VT0 + .align 3 + +.L26: + xvfcmp.ceq.d VT0, VM0, x2 + fcmp.ceq.d $fcc0, $f23, $f17 + bceqz $fcc0, .L27 + xvfcmp.clt.d VT0, VI2, VI0 + xvbitsel.v VI0, VI0, VI2, VT0 + .align 3 + +.L27: + xvfcmp.ceq.d VT0, VM0, x3 + fcmp.ceq.d $fcc0, $f23, $f17 + bceqz $fcc0, .L28 + xvfcmp.clt.d VT0, VI3, VI0 + xvbitsel.v VI0, VI0, VI3, VT0 + .align 3 + +.L28: + xvfcmp.ceq.d VT0, VM0, x4 + fcmp.ceq.d $fcc0, $f23, $f17 + bceqz $fcc0, .L29 + xvfcmp.clt.d VT0, VI4, VI0 + xvbitsel.v VI0, VI0, VI4, VT0 + .align 3 + +.L29: + movfr2gr.d i0, $f20 + .align 3 + +.L21: //N<8 + andi I, N, 7 + bge $r0, I, .L999 + srai.d i1, N, 3 + slli.d i1, i1, 3 + addi.d i1, i1, 1 //current index + movgr2fr.d $f21, i1 + movgr2fr.d $f20, i0 + .align 3 + +.L22: + fld.d $f9, X, 0 + addi.d I, I, -1 + fcmp.clt.d $fcc0, $f9, $f15 + add.d X, X, INCX + fsel $f15, $f15, $f9, $fcc0 + fsel $f20, $f20, $f21, $fcc0 + addi.d i1, i1, 1 + movgr2fr.d $f21, i1 + blt $r0, I, .L22 + movfr2gr.d i0, $f20 + .align 3 + +.L999: + move $r4, $r17 + jirl $r0, $r1, 0x0 + .align 3 + + EPILOGUE \ No newline at end of file diff --git a/kernel/loongarch64/idmin_lsx.S b/kernel/loongarch64/idmin_lsx.S new file mode 100644 index 000000000..8b6edcbf0 --- /dev/null +++ b/kernel/loongarch64/idmin_lsx.S @@ -0,0 +1,225 @@ +#define ASSEMBLER + +#include "common.h" + +#define N $r4 +#define X $r5 +#define INCX $r6 +#define I $r12 +#define t1 $r13 +#define t2 $r15 +#define t3 $r18 +#define t4 $r16 +#define i0 $r17 +#define i1 $r14 +#define TEMP $r19 +#define x1 $vr9 +#define x2 $vr10 +#define x3 $vr11 +#define x4 $vr12 +#define VX0 $vr13 +#define VX1 $vr14 +#define VM0 $vr15 +#define VM1 $vr16 +#define VINC2 $vr17 +#define VINC4 $vr18 +#define VI0 $vr20 +#define VI1 $vr21 +#define VI2 $vr22 +#define VI3 $vr8 +#define VI4 $vr19 +#define VT0 $vr23 + + PROLOGUE + li.d i0, 0 + bge $r0, N, .L999 + bge $r0, INCX, .L999 + li.d TEMP, 1 + slli.d TEMP, TEMP, BASE_SHIFT + slli.d INCX, INCX, BASE_SHIFT + bne INCX, TEMP, .L20 + vld VM0, X, 0 + addi.d i0, i0, 1 + srai.d I, N, 3 + bge $r0, I, .L21 + slli.d i0, i0, 1 //2 + vreplgr2vr.d VINC2, i0 + slli.d i0, i0, 1 //4 + vreplgr2vr.d VINC4, i0 + addi.d i0, i0, -7 + vinsgr2vr.d VI1, i0, 0 //initialize the index value for vectorization + addi.d i0, i0, 1 + vinsgr2vr.d VI1, i0, 1 + addi.d i0, i0, 3 + vinsgr2vr.d VI0, i0, 0 //1 + addi.d i0, i0, 1 + vinsgr2vr.d VI0, i0, 1 //2 + .align 3 + +.L10: + vld VX0, X, 0 * SIZE + vadd.d VI1, VI1, VINC4 + vld VX1, X, 2 * SIZE + vadd.d VI2, VI1, VINC2 + vfcmp.clt.d VT0, VX1, VX0 + vbitsel.v x1, VX0, VX1, VT0 + vbitsel.v x2, VI1, VI2, VT0 + vld VX0, X, 4 * SIZE + vadd.d VI1, VI2, VINC2 + vld VX1, X, 6 * SIZE + vadd.d VI2, VI1, VINC2 + vfcmp.clt.d VT0, VX1, VX0 + addi.d I, I, -1 + vbitsel.v x3, VX0, VX1, VT0 + vbitsel.v x4, VI1, VI2, VT0 + vfcmp.clt.d VT0, x3, x1 + addi.d X, X, 8 * SIZE + vbitsel.v x1, x1, x3, VT0 + vbitsel.v x2, x2, x4, VT0 + vfcmp.clt.d VT0, x1, VM0 + vbitsel.v VM0, VM0, x1, VT0 + vbitsel.v VI0, VI0, x2, VT0 + blt $r0, I, .L10 + .align 3 + +.L15: + vreplvei.d VI1, VI0, 0 + vreplvei.d VI2, VI0, 1 + vreplvei.d x1, VM0, 0 + vreplvei.d x2, VM0, 1 + li.d TEMP, 1 //处理尾数相等时取最小序号 + movgr2fr.d $f17, TEMP + ffint.d.l $f17, $f17 + vfcmp.ceq.d VT0, x2, x1 + fcmp.ceq.d $fcc0, $f23, $f17 + bceqz $fcc0, .L26 + vfcmp.clt.d VT0, VI1, VI0 + vbitsel.v VI0, VI0, VI1, VT0 + b .L27 + .align 3 + +.L20: // INCX!=1 + move TEMP, X + addi.d i0, i0, 1 + ld.d t1, TEMP, 0 * SIZE + add.d TEMP, TEMP, INCX + vinsgr2vr.d VM0, t1, 0 + srai.d I, N, 3 + bge $r0, I, .L21 + ld.d t2, TEMP, 0 * SIZE + add.d TEMP, TEMP, INCX + vinsgr2vr.d VM0, t2, 1 + slli.d i0, i0, 1 //2 + vreplgr2vr.d VINC2, i0 + slli.d i0, i0, 1 //4 + vreplgr2vr.d VINC4, i0 + addi.d i0, i0, -7 + vinsgr2vr.d VI1, i0, 0 //initialize the index value for vectorization + addi.d i0, i0, 1 + vinsgr2vr.d VI1, i0, 1 + addi.d i0, i0, 3 + vinsgr2vr.d VI0, i0, 0 //1 + addi.d i0, i0, 1 + vinsgr2vr.d VI0, i0, 1 //2 + .align 3 + +.L24: + ld.d t1, X, 0 * SIZE + add.d X, X, INCX + ld.d t2, X, 0 * SIZE + add.d X, X, INCX + vinsgr2vr.d VX0, t1, 0 + vinsgr2vr.d VX0, t2, 1 + vadd.d VI1, VI1, VINC4 + ld.d t1, X, 0 * SIZE + add.d X, X, INCX + ld.d t2, X, 0 * SIZE + add.d X, X, INCX + vinsgr2vr.d VX1, t1, 0 + vinsgr2vr.d VX1, t2, 1 + vadd.d VI2, VI1, VINC2 + vfcmp.clt.d VT0, VX1, VX0 + vbitsel.v x1, VX0, VX1, VT0 + vbitsel.v x2, VI1, VI2, VT0 + ld.d t1, X, 0 * SIZE + add.d X, X, INCX + ld.d t2, X, 0 * SIZE + add.d X, X, INCX + vinsgr2vr.d VX0, t1, 0 + vinsgr2vr.d VX0, t2, 1 + vadd.d VI1, VI2, VINC2 + ld.d t1, X, 0 * SIZE + add.d X, X, INCX + ld.d t2, X, 0 * SIZE + add.d X, X, INCX + vinsgr2vr.d VX1, t1, 0 + vinsgr2vr.d VX1, t2, 1 + vadd.d VI2, VI1, VINC2 + vfcmp.clt.d VT0, VX1, VX0 + vbitsel.v x3, VX0, VX1, VT0 + vbitsel.v x4, VI1, VI2, VT0 + vfcmp.clt.d VT0, x3, x1 + vbitsel.v x1, x1, x3, VT0 + vbitsel.v x2, x2, x4, VT0 + vfcmp.clt.d VT0, x1, VM0 + addi.d I, I, -1 + vbitsel.v VM0, VM0, x1, VT0 + vbitsel.v VI0, VI0, x2, VT0 + blt $r0, I, .L24 + .align 3 + +.L25: + vreplvei.d VI1, VI0, 0 + vreplvei.d VI2, VI0, 1 + vreplvei.d x1, VM0, 0 + vreplvei.d x2, VM0, 1 + li.d TEMP, 1 //处理尾数相等时取最小序号 + movgr2fr.d $f17, TEMP + ffint.d.l $f17, $f17 + vfcmp.ceq.d VT0, x2, x1 + fcmp.ceq.d $fcc0, $f23, $f17 + bceqz $fcc0, .L26 + vfcmp.clt.d VT0, VI1, VI0 + vbitsel.v VI0, VI0, VI1, VT0 + b .L27 + .align 3 + +.L26: + vfcmp.clt.d VT0, x2, x1 + vbitsel.v VM0, x1, x2, VT0 + vbitsel.v VI0, VI1, VI2, VT0 + .align 3 + +.L27: + movfr2gr.d i0, $f20 + .align 3 + +.L21: //N<8 + andi I, N, 7 + bge $r0, I, .L999 + srai.d i1, N, 3 + slli.d i1, i1, 3 + addi.d i1, i1, 1 //current index + movgr2fr.d $f21, i1 + movgr2fr.d $f20, i0 + .align 3 + +.L22: + fld.d $f9, X, 0 + addi.d I, I, -1 + fcmp.clt.d $fcc0, $f9, $f15 + add.d X, X, INCX + fsel $f15, $f15, $f9, $fcc0 + fsel $f20, $f20, $f21, $fcc0 + addi.d i1, i1, 1 + movgr2fr.d $f21, i1 + blt $r0, I, .L22 + movfr2gr.d i0, $f20 + .align 3 + +.L999: + move $r4, $r17 + jirl $r0, $r1, 0x0 + .align 3 + + EPILOGUE \ No newline at end of file diff --git a/kernel/loongarch64/ismin_lasx.S b/kernel/loongarch64/ismin_lasx.S new file mode 100644 index 000000000..15f6e2ec9 --- /dev/null +++ b/kernel/loongarch64/ismin_lasx.S @@ -0,0 +1,374 @@ +#define ASSEMBLER + +#include "common.h" + +#define N $r4 +#define X $r5 +#define INCX $r6 +#define I $r12 +#define t1 $r13 +#define t2 $r15 +#define t3 $r18 +#define t4 $r16 +#define i0 $r17 +#define i1 $r14 +#define TEMP $r19 +#define x1 $xr9 +#define x2 $xr10 +#define x3 $xr11 +#define x4 $xr12 +#define VX0 $xr13 +#define VX1 $xr14 +#define VM0 $xr15 +#define VM1 $xr16 +#define VINC4 $xr17 +#define VINC8 $xr18 +#define VI0 $xr20 +#define VI1 $xr21 +#define VI2 $xr22 +#define VI3 $xr8 +#define VI4 $xr19 +#define VT0 $xr23 + + PROLOGUE + li.d i0, 0 + bge $r0, N, .L999 + bge $r0, INCX, .L999 + li.d TEMP, 1 + slli.d TEMP, TEMP, BASE_SHIFT + slli.d INCX, INCX, BASE_SHIFT + bne INCX, TEMP, .L20 + xvld VM0, X, 0 + addi.w i0, i0, 1 + srai.d I, N, 3 + bge $r0, I, .L21 + slli.w i0, i0, 3 //8 + xvreplgr2vr.w VINC8, i0 + addi.w i0, i0, -15 + xvinsgr2vr.w VI1, i0, 0 //initialize the index value for vectorization + addi.w i0, i0, 1 + xvinsgr2vr.w VI1, i0, 1 + addi.w i0, i0, 1 + xvinsgr2vr.w VI1, i0, 2 + addi.w i0, i0, 1 + xvinsgr2vr.w VI1, i0, 3 + addi.w i0, i0, 1 + xvinsgr2vr.w VI1, i0, 4 + addi.w i0, i0, 1 + xvinsgr2vr.w VI1, i0, 5 + addi.w i0, i0, 1 + xvinsgr2vr.w VI1, i0, 6 + addi.w i0, i0, 1 + xvinsgr2vr.w VI1, i0, 7 + addi.w i0, i0, 1 + xvinsgr2vr.w VI0, i0, 0 //1 + addi.w i0, i0, 1 + xvinsgr2vr.w VI0, i0, 1 //2 + addi.w i0, i0, 1 + xvinsgr2vr.w VI0, i0, 2 //3 + addi.w i0, i0, 1 + xvinsgr2vr.w VI0, i0, 3 //4 + addi.w i0, i0, 1 + xvinsgr2vr.w VI0, i0, 4 //5 + addi.w i0, i0, 1 + xvinsgr2vr.w VI0, i0, 5 //6 + addi.w i0, i0, 1 + xvinsgr2vr.w VI0, i0, 6 //7 + addi.w i0, i0, 1 + xvinsgr2vr.w VI0, i0, 7 //8 + .align 3 + +.L10: + xvld VX0, X, 0 * SIZE + xvadd.w VI1, VI1, VINC8 + xvfcmp.clt.s VT0, VX0, VM0 + addi.d I, I, -1 + xvbitsel.v VM0, VM0, VX0, VT0 + xvbitsel.v VI0, VI0, VI1, VT0 + addi.d X, X, 8 * SIZE + blt $r0, I, .L10 + .align 3 + +.L15: + xvxor.v VX0, VX0, VX0 + xvor.v VX0, VI0, VX0 + xvxor.v VX1, VX1, VX1 + xvor.v VX1, VM0, VX1 + xvpickve.w VI1, VI0, 0 + xvpickve.w VI2, VI0, 1 + xvpickve.w VI3, VI0, 2 + xvpickve.w VI4, VI0, 3 + xvpickve.w x1, VM0, 0 + xvpickve.w x2, VM0, 1 + xvpickve.w x3, VM0, 2 + xvpickve.w x4, VM0, 3 + xvfcmp.clt.s VT0, x2, x1 + xvbitsel.v VM1, x1, x2, VT0 + xvbitsel.v VINC4, VI1, VI2, VT0 + xvfcmp.clt.s VT0, x4, x3 + xvbitsel.v VM0, x3, x4, VT0 + xvbitsel.v VINC8, VI3, VI4, VT0 + xvfcmp.clt.s VT0, VM1, VM0 + xvbitsel.v VM0, VM0, VM1, VT0 + xvbitsel.v VI0, VINC8, VINC4, VT0 + li.d TEMP, 1 //处理尾数相等时取最小序号 + movgr2fr.w $f17, TEMP + ffint.s.w $f17, $f17 + xvfcmp.ceq.s VT0, x1, VM0 + fcmp.ceq.s $fcc0, $f23, $f17 + bceqz $fcc0, .L26 + xvfcmp.clt.s VT0, VI1, VI0 + xvbitsel.v VI0, VI0, VI1, VT0 + b .L26 + .align 3 + +.L20: // INCX!=1 + move TEMP, X + addi.w i0, i0, 1 + ld.w t1, TEMP, 0 * SIZE + add.d TEMP, TEMP, INCX + srai.d I, N, 3 + bge $r0, I, .L21 + ld.w t2, TEMP, 0 * SIZE + add.d TEMP, TEMP, INCX + ld.w t3, TEMP, 0 * SIZE + add.d TEMP, TEMP, INCX + ld.w t4, TEMP, 0 * SIZE + add.d TEMP, TEMP, INCX + xvinsgr2vr.w VM0, t1, 0 + xvinsgr2vr.w VM0, t2, 1 + xvinsgr2vr.w VM0, t3, 2 + xvinsgr2vr.w VM0, t4, 3 + ld.w t1, TEMP, 0 * SIZE + add.d TEMP, TEMP, INCX + ld.w t2, TEMP, 0 * SIZE + add.d TEMP, TEMP, INCX + ld.w t3, TEMP, 0 * SIZE + add.d TEMP, TEMP, INCX + ld.w t4, TEMP, 0 * SIZE + add.d TEMP, TEMP, INCX + xvinsgr2vr.w VM0, t1, 4 + xvinsgr2vr.w VM0, t2, 5 + xvinsgr2vr.w VM0, t3, 6 + xvinsgr2vr.w VM0, t4, 7 + slli.w i0, i0, 3 //8 + xvreplgr2vr.w VINC8, i0 + addi.w i0, i0, -15 + xvinsgr2vr.w VI1, i0, 0 //initialize the index value for vectorization + addi.w i0, i0, 1 + xvinsgr2vr.w VI1, i0, 1 + addi.w i0, i0, 1 + xvinsgr2vr.w VI1, i0, 2 + addi.w i0, i0, 1 + xvinsgr2vr.w VI1, i0, 3 + addi.w i0, i0, 1 + xvinsgr2vr.w VI1, i0, 4 + addi.w i0, i0, 1 + xvinsgr2vr.w VI1, i0, 5 + addi.w i0, i0, 1 + xvinsgr2vr.w VI1, i0, 6 + addi.w i0, i0, 1 + xvinsgr2vr.w VI1, i0, 7 + addi.w i0, i0, 1 + xvinsgr2vr.w VI0, i0, 0 //1 + addi.w i0, i0, 1 + xvinsgr2vr.w VI0, i0, 1 //2 + addi.w i0, i0, 1 + xvinsgr2vr.w VI0, i0, 2 //3 + addi.w i0, i0, 1 + xvinsgr2vr.w VI0, i0, 3 //4 + addi.w i0, i0, 1 + xvinsgr2vr.w VI0, i0, 4 //5 + addi.w i0, i0, 1 + xvinsgr2vr.w VI0, i0, 5 //6 + addi.w i0, i0, 1 + xvinsgr2vr.w VI0, i0, 6 //7 + addi.w i0, i0, 1 + xvinsgr2vr.w VI0, i0, 7 //8 + .align 3 + +.L24: + ld.w t1, X, 0 * SIZE + add.d X, X, INCX + ld.w t2, X, 0 * SIZE + add.d X, X, INCX + ld.w t3, X, 0 * SIZE + add.d X, X, INCX + ld.w t4, X, 0 * SIZE + add.d X, X, INCX + xvinsgr2vr.w VX0, t1, 0 + xvinsgr2vr.w VX0, t2, 1 + xvinsgr2vr.w VX0, t3, 2 + xvinsgr2vr.w VX0, t4, 3 + ld.w t1, X, 0 * SIZE + add.d X, X, INCX + ld.w t2, X, 0 * SIZE + add.d X, X, INCX + ld.w t3, X, 0 * SIZE + add.d X, X, INCX + ld.w t4, X, 0 * SIZE + add.d X, X, INCX + xvinsgr2vr.w VX0, t1, 4 + xvinsgr2vr.w VX0, t2, 5 + xvinsgr2vr.w VX0, t3, 6 + xvinsgr2vr.w VX0, t4, 7 + xvadd.w VI1, VI1, VINC8 + xvfcmp.clt.s VT0, VX0, VM0 + addi.d I, I, -1 + xvbitsel.v VM0, VM0, VX0, VT0 + xvbitsel.v VI0, VI0, VI1, VT0 + blt $r0, I, .L24 + .align 3 + +.L25: + xvxor.v VX0, VX0, VX0 + xvor.v VX0, VI0, VX0 + xvxor.v VX1, VX1, VX1 + xvor.v VX1, VM0, VX1 + xvpickve.w VI1, VI0, 0 + xvpickve.w VI2, VI0, 1 + xvpickve.w VI3, VI0, 2 + xvpickve.w VI4, VI0, 3 + xvpickve.w x1, VM0, 0 + xvpickve.w x2, VM0, 1 + xvpickve.w x3, VM0, 2 + xvpickve.w x4, VM0, 3 + xvfcmp.clt.s VT0, x2, x1 + xvbitsel.v VM1, x1, x2, VT0 + xvbitsel.v VINC4, VI1, VI2, VT0 + xvfcmp.clt.s VT0, x4, x3 + xvbitsel.v VM0, x3, x4, VT0 + xvbitsel.v VINC8, VI3, VI4, VT0 + xvfcmp.clt.s VT0, VM1, VM0 + xvbitsel.v VM0, VM0, VM1, VT0 + xvbitsel.v VI0, VINC8, VINC4, VT0 + li.d TEMP, 1 //处理尾数相等时取最小序号 + movgr2fr.w $f17, TEMP + ffint.s.w $f17, $f17 + xvfcmp.ceq.s VT0, VM0, x1 + fcmp.ceq.s $fcc0, $f23, $f17 + bceqz $fcc0, .L26 + xvfcmp.clt.s VT0, VI1, VI0 + xvbitsel.v VI0, VI0, VI1, VT0 + .align 3 + +.L26: + xvfcmp.ceq.s VT0, VM0, x2 + fcmp.ceq.s $fcc0, $f23, $f17 + bceqz $fcc0, .L27 + xvfcmp.clt.s VT0, VI2, VI0 + xvbitsel.v VI0, VI0, VI2, VT0 + .align 3 + +.L27: + xvfcmp.ceq.s VT0, VM0, x3 + fcmp.ceq.s $fcc0, $f23, $f17 + bceqz $fcc0, .L28 + xvfcmp.clt.s VT0, VI3, VI0 + xvbitsel.v VI0, VI0, VI3, VT0 + .align 3 + +.L28: + xvfcmp.ceq.s VT0, VM0, x4 + fcmp.ceq.s $fcc0, $f23, $f17 + bceqz $fcc0, .L29 + xvfcmp.clt.s VT0, VI4, VI0 + xvbitsel.v VI0, VI0, VI4, VT0 + .align 3 + +.L29: + fmov.s $f16, $f20 + .align 3 + +.L252: + xvxor.v VI0, VI0, VI0 + xvor.v VI0, VI0, VX0 + fmov.s $f13, $f15 + xvxor.v VM0, VM0, VM0 + xvor.v VM0, VM0, VX1 + xvpickve.w VI1, VI0, 4 + xvpickve.w VI2, VI0, 5 + xvpickve.w VI3, VI0, 6 + xvpickve.w VI4, VI0, 7 + xvpickve.w x1, VM0, 4 + xvpickve.w x2, VM0, 5 + xvpickve.w x3, VM0, 6 + xvpickve.w x4, VM0, 7 + xvfcmp.clt.s VT0, x2, x1 + xvbitsel.v x1, x1, x2, VT0 + xvbitsel.v VINC4, VI1, VI2, VT0 + xvfcmp.clt.s VT0, x4, x3 + xvbitsel.v VM0, x3, x4, VT0 + xvbitsel.v VINC8, VI3, VI4, VT0 + xvfcmp.clt.s VT0, x1, VM0 + xvbitsel.v VM0, VM0, x1, VT0 + xvbitsel.v VI0, VINC8, VINC4, VT0 + li.d TEMP, 1 //处理尾数相等时取最小序号 + movgr2fr.w $f17, TEMP + ffint.s.w $f17, $f17 + xvfcmp.ceq.s VT0, VM0, x1 + fcmp.ceq.s $fcc0, $f23, $f17 + bceqz $fcc0, .L262 + xvfcmp.clt.s VT0, VI1, VI0 + xvbitsel.v VI0, VI0, VI1, VT0 + .align 3 + +.L262: + xvfcmp.ceq.s VT0, VM0, x2 + fcmp.ceq.s $fcc0, $f23, $f17 + bceqz $fcc0, .L272 + xvfcmp.clt.s VT0, VI2, VI0 + xvbitsel.v VI0, VI0, VI2, VT0 + .align 3 + +.L272: + xvfcmp.ceq.s VT0, VM0, x3 + fcmp.ceq.s $fcc0, $f23, $f17 + bceqz $fcc0, .L282 + xvfcmp.clt.s VT0, VI3, VI0 + xvbitsel.v VI0, VI0, VI3, VT0 + .align 3 + +.L282: + xvfcmp.ceq.s VT0, VM0, x4 + fcmp.ceq.s $fcc0, $f23, $f17 + bceqz $fcc0, .L292 + xvfcmp.clt.s VT0, VI4, VI0 + xvbitsel.v VI0, VI0, VI4, VT0 + .align 3 + +.L292: + fcmp.clt.s $fcc0, $f13, $f15 + fsel $f15, $f15, $f13, $fcc0 + fsel $f20, $f20, $f16, $fcc0 + movfr2gr.s i0, $f20 + +.L21: //N<8 + andi I, N, 7 + bge $r0, I, .L999 + srai.d i1, N, 3 + slli.d i1, i1, 3 + addi.d i1, i1, 1 //current index + movgr2fr.d $f21, i1 + movgr2fr.d $f20, i0 + .align 3 + +.L22: + fld.d $f9, X, 0 + addi.d I, I, -1 + fcmp.clt.s $fcc0, $f9, $f15 + fsel $f15, $f15, $f9, $fcc0 + fsel $f20, $f20, $f21, $fcc0 + addi.d i1, i1, 1 + movgr2fr.d $f21, i1 + add.d X, X, INCX + blt $r0, I, .L22 + movfr2gr.s i0, $f20 + .align 3 + +.L999: + move $r4, $r17 + jirl $r0, $r1, 0x0 + .align 3 + + EPILOGUE \ No newline at end of file diff --git a/kernel/loongarch64/ismin_lsx.S b/kernel/loongarch64/ismin_lsx.S new file mode 100644 index 000000000..f90ebbd57 --- /dev/null +++ b/kernel/loongarch64/ismin_lsx.S @@ -0,0 +1,271 @@ +#define ASSEMBLER + +#include "common.h" + +#define N $r4 +#define X $r5 +#define INCX $r6 +#define I $r12 +#define t1 $r13 +#define t2 $r15 +#define t3 $r18 +#define t4 $r16 +#define i0 $r17 +#define i1 $r14 +#define TEMP $r19 +#define x1 $vr9 +#define x2 $vr10 +#define x3 $vr11 +#define x4 $vr12 +#define VX0 $vr13 +#define VX1 $vr14 +#define VM0 $vr15 +#define VM1 $vr16 +#define VINC4 $vr17 +#define VINC8 $vr18 +#define VI0 $vr20 +#define VI1 $vr21 +#define VI2 $vr22 +#define VI3 $vr8 +#define VI4 $vr19 +#define VT0 $vr23 + + PROLOGUE + li.d i0, 0 + bge $r0, N, .L999 + bge $r0, INCX, .L999 + li.d TEMP, 1 + slli.d TEMP, TEMP, BASE_SHIFT + slli.d INCX, INCX, BASE_SHIFT + bne INCX, TEMP, .L20 + vld VM0, X, 0 + addi.w i0, i0, 1 + srai.d I, N, 3 + bge $r0, I, .L21 + slli.w i0, i0, 2 //4 + vreplgr2vr.w VINC4, i0 + slli.w i0, i0, 1 //8 + vreplgr2vr.w VINC8, i0 + addi.w i0, i0, -15 + vinsgr2vr.w VI1, i0, 0 //initialize the index value for vectorization + addi.w i0, i0, 1 + vinsgr2vr.w VI1, i0, 1 + addi.w i0, i0, 1 + vinsgr2vr.w VI1, i0, 2 + addi.w i0, i0, 1 + vinsgr2vr.w VI1, i0, 3 + addi.w i0, i0, 5 + vinsgr2vr.w VI0, i0, 0 //1 + addi.w i0, i0, 1 + vinsgr2vr.w VI0, i0, 1 //2 + addi.w i0, i0, 1 + vinsgr2vr.w VI0, i0, 2 //3 + addi.w i0, i0, 1 + vinsgr2vr.w VI0, i0, 3 //4 + .align 3 + +.L10: + vld VX0, X, 0 * SIZE + vadd.w VI1, VI1, VINC8 + vld VX1, X, 4 * SIZE + vadd.w VI2, VI1, VINC4 + vfcmp.clt.s VT0, VX1, VX0 + addi.d I, I, -1 + vbitsel.v VM1, VX0, VX1, VT0 + vbitsel.v VI2, VI1, VI2, VT0 + vfcmp.clt.s VT0, VM1, VM0 + addi.d X, X, 8 * SIZE + vbitsel.v VM0, VM0, VM1, VT0 + vbitsel.v VI0, VI0, VI2, VT0 + blt $r0, I, .L10 + .align 3 + +.L15: + vreplvei.w VI1, VI0, 0 + vreplvei.w VI2, VI0, 1 + vreplvei.w VI3, VI0, 2 + vreplvei.w VI4, VI0, 3 + vreplvei.w x1, VM0, 0 + vreplvei.w x2, VM0, 1 + vreplvei.w x3, VM0, 2 + vreplvei.w x4, VM0, 3 + vfcmp.clt.s VT0, x2, x1 + vbitsel.v VM1, x1, x2, VT0 + vbitsel.v VINC4, VI1, VI2, VT0 + vfcmp.clt.s VT0, x4, x3 + vbitsel.v VM0, x3, x4, VT0 + vbitsel.v VINC8, VI3, VI4, VT0 + vfcmp.clt.s VT0, VM1, VM0 + vbitsel.v VM0, VM0, VM1, VT0 + vbitsel.v VI0, VINC8, VINC4, VT0 + li.d TEMP, 1 //处理尾数相等时取最小序号 + movgr2fr.w $f17, TEMP + ffint.s.w $f17, $f17 + vfcmp.ceq.s VT0, x1, VM0 + fcmp.ceq.s $fcc0, $f23, $f17 + bceqz $fcc0, .L26 + vfcmp.clt.s VT0, VI1, VI0 + vbitsel.v VI0, VI0, VI1, VT0 + b .L26 + .align 3 + +.L20: // INCX!=1 + move TEMP, X + addi.w i0, i0, 1 + ld.w t1, TEMP, 0 * SIZE + add.d TEMP, TEMP, INCX + vinsgr2vr.w VM0, t1, 0 + srai.d I, N, 3 + bge $r0, I, .L21 + ld.w t2, TEMP, 0 * SIZE + add.d TEMP, TEMP, INCX + ld.w t3, TEMP, 0 * SIZE + add.d TEMP, TEMP, INCX + ld.w t4, TEMP, 0 * SIZE + add.d TEMP, TEMP, INCX + vinsgr2vr.w VM0, t2, 1 + vinsgr2vr.w VM0, t3, 2 + vinsgr2vr.w VM0, t4, 3 + slli.w i0, i0, 2 //4 + vreplgr2vr.w VINC4, i0 + slli.w i0, i0, 1 //8 + vreplgr2vr.w VINC8, i0 + addi.w i0, i0, -15 + vinsgr2vr.w VI1, i0, 0 //initialize the index value for vectorization + addi.w i0, i0, 1 + vinsgr2vr.w VI1, i0, 1 + addi.w i0, i0, 1 + vinsgr2vr.w VI1, i0, 2 + addi.w i0, i0, 1 + vinsgr2vr.w VI1, i0, 3 + addi.w i0, i0, 5 + vinsgr2vr.w VI0, i0, 0 //1 + addi.w i0, i0, 1 + vinsgr2vr.w VI0, i0, 1 //2 + addi.w i0, i0, 1 + vinsgr2vr.w VI0, i0, 2 //3 + addi.w i0, i0, 1 + vinsgr2vr.w VI0, i0, 3 //4 + .align 3 + +.L24: + ld.w t1, X, 0 * SIZE + add.d X, X, INCX + ld.w t2, X, 0 * SIZE + add.d X, X, INCX + ld.w t3, X, 0 * SIZE + add.d X, X, INCX + ld.w t4, X, 0 * SIZE + add.d X, X, INCX + vinsgr2vr.w VX0, t1, 0 + vinsgr2vr.w VX0, t2, 1 + vinsgr2vr.w VX0, t3, 2 + vinsgr2vr.w VX0, t4, 3 + vadd.w VI1, VI1, VINC8 + ld.w t1, X, 0 * SIZE + add.d X, X, INCX + ld.w t2, X, 0 * SIZE + add.d X, X, INCX + ld.w t3, X, 0 * SIZE + add.d X, X, INCX + ld.w t4, X, 0 * SIZE + add.d X, X, INCX + vinsgr2vr.w VX1, t1, 0 + vinsgr2vr.w VX1, t2, 1 + vinsgr2vr.w VX1, t3, 2 + vinsgr2vr.w VX1, t4, 3 + vadd.w VI2, VI1, VINC4 + vfcmp.clt.s VT0, VX1, VX0 + addi.d I, I, -1 + vbitsel.v VM1, VX0, VX1, VT0 + vbitsel.v VI2, VI1, VI2, VT0 + vfcmp.clt.s VT0, VM1, VM0 + vbitsel.v VM0, VM0, VM1, VT0 + vbitsel.v VI0, VI0, VI2, VT0 + blt $r0, I, .L24 + .align 3 + +.L25: + vreplvei.w VI1, VI0, 0 + vreplvei.w VI2, VI0, 1 + vreplvei.w VI3, VI0, 2 + vreplvei.w VI4, VI0, 3 + vreplvei.w x1, VM0, 0 + vreplvei.w x2, VM0, 1 + vreplvei.w x3, VM0, 2 + vreplvei.w x4, VM0, 3 + vfcmp.clt.s VT0, x2, x1 + vbitsel.v VM1, x1, x2, VT0 + vbitsel.v VINC4, VI1, VI2, VT0 + vfcmp.clt.s VT0, x4, x3 + vbitsel.v VM0, x3, x4, VT0 + vbitsel.v VINC8, VI3, VI4, VT0 + vfcmp.clt.s VT0, VM1, VM0 + vbitsel.v VM0, VM0, VM1, VT0 + vbitsel.v VI0, VINC8, VINC4, VT0 + li.d TEMP, 1 //处理尾数相等时取最小序号 + movgr2fr.w $f17, TEMP + ffint.s.w $f17, $f17 + vfcmp.ceq.s VT0, x1, VM0 + fcmp.ceq.s $fcc0, $f23, $f17 + bceqz $fcc0, .L26 + vfcmp.clt.s VT0, VI1, VI0 + vbitsel.v VI0, VI0, VI1, VT0 + .align 3 + +.L26: + vfcmp.ceq.s VT0, x2, VM0 + fcmp.ceq.s $fcc0, $f23, $f17 + bceqz $fcc0, .L27 + vfcmp.clt.s VT0, VI2, VI0 + vbitsel.v VI0, VI0, VI2, VT0 + .align 3 + +.L27: + vfcmp.ceq.s VT0, x3, VM0 + fcmp.ceq.s $fcc0, $f23, $f17 + bceqz $fcc0, .L28 + vfcmp.clt.s VT0, VI3, VI0 + vbitsel.v VI0, VI0, VI3, VT0 + .align 3 + +.L28: + vfcmp.ceq.s VT0, x4, VM0 + fcmp.ceq.s $fcc0, $f23, $f17 + bceqz $fcc0, .L29 + vfcmp.clt.s VT0, VI4, VI0 + vbitsel.v VI0, VI0, VI4, VT0 + .align 3 + +.L29: + movfr2gr.s i0, $f20 + +.L21: //N<8 + andi I, N, 7 + bge $r0, I, .L999 + srai.d i1, N, 3 + slli.d i1, i1, 3 + addi.d i1, i1, 1 //current index + movgr2fr.d $f21, i1 + movgr2fr.d $f20, i0 + .align 3 + +.L22: + fld.d $f9, X, 0 + fcmp.clt.s $fcc0, $f9, $f15 + fsel $f15, $f15, $f9, $fcc0 + fsel $f20, $f20, $f21, $fcc0 + addi.d I, I, -1 + addi.d i1, i1, 1 + add.d X, X, INCX + movgr2fr.d $f21, i1 + blt $r0, I, .L22 + movfr2gr.s i0, $f20 + .align 3 + +.L999: + move $r4, $r17 + jirl $r0, $r1, 0x0 + .align 3 + + EPILOGUE \ No newline at end of file From be83f5e4e08bfc5a7d94d5ed659368ca077c4374 Mon Sep 17 00:00:00 2001 From: yancheng Date: Thu, 7 Dec 2023 12:07:30 +0800 Subject: [PATCH 50/60] loongarch64: Add optimizations for iamax. --- kernel/loongarch64/KERNEL.LOONGSON2K1000 | 3 + kernel/loongarch64/KERNEL.LOONGSON3R5 | 3 + kernel/loongarch64/idamax_lasx.S | 275 +++++++++++++++++ kernel/loongarch64/idamax_lsx.S | 267 ++++++++++++++++ kernel/loongarch64/isamax_lasx.S | 378 +++++++++++++++++++++++ kernel/loongarch64/isamax_lsx.S | 275 +++++++++++++++++ 6 files changed, 1201 insertions(+) create mode 100644 kernel/loongarch64/idamax_lasx.S create mode 100644 kernel/loongarch64/idamax_lsx.S create mode 100644 kernel/loongarch64/isamax_lasx.S create mode 100644 kernel/loongarch64/isamax_lsx.S diff --git a/kernel/loongarch64/KERNEL.LOONGSON2K1000 b/kernel/loongarch64/KERNEL.LOONGSON2K1000 index d0eab3d7c..a4c8927ba 100644 --- a/kernel/loongarch64/KERNEL.LOONGSON2K1000 +++ b/kernel/loongarch64/KERNEL.LOONGSON2K1000 @@ -25,4 +25,7 @@ IDMAXKERNEL = idmax_lsx.S ISMINKERNEL = ismin_lsx.S IDMINKERNEL = idmin_lsx.S +ISAMAXKERNEL = isamax_lsx.S +IDAMAXKERNEL = idamax_lsx.S + endif diff --git a/kernel/loongarch64/KERNEL.LOONGSON3R5 b/kernel/loongarch64/KERNEL.LOONGSON3R5 index 92389001b..835b027b8 100644 --- a/kernel/loongarch64/KERNEL.LOONGSON3R5 +++ b/kernel/loongarch64/KERNEL.LOONGSON3R5 @@ -25,6 +25,9 @@ IDMAXKERNEL = idmax_lasx.S ISMINKERNEL = ismin_lasx.S IDMINKERNEL = idmin_lasx.S +ISAMAXKERNEL = isamax_lasx.S +IDAMAXKERNEL = idamax_lasx.S + DGEMMKERNEL = dgemm_kernel_16x4.S DGEMMINCOPY = dgemm_ncopy_16.S DGEMMITCOPY = dgemm_tcopy_16.S diff --git a/kernel/loongarch64/idamax_lasx.S b/kernel/loongarch64/idamax_lasx.S new file mode 100644 index 000000000..8248ee757 --- /dev/null +++ b/kernel/loongarch64/idamax_lasx.S @@ -0,0 +1,275 @@ +#define ASSEMBLER + +#include "common.h" + +#define N $r4 +#define X $r5 +#define INCX $r6 +#define I $r12 +#define t1 $r13 +#define t2 $r15 +#define t3 $r18 +#define t4 $r16 +#define i0 $r17 +#define i1 $r14 +#define TEMP $r19 +#define x1 $xr9 +#define x2 $xr10 +#define x3 $xr11 +#define x4 $xr12 +#define VX0 $xr13 +#define VX1 $xr14 +#define VM0 $xr15 +#define VM1 $xr16 +#define VINC4 $xr17 +#define VINC8 $xr18 +#define VI0 $xr20 +#define VI1 $xr21 +#define VI2 $xr22 +#define VI3 $xr8 +#define VI4 $xr19 +#define VT0 $xr23 + + PROLOGUE + li.d i0, 0 + bge $r0, N, .L999 + bge $r0, INCX, .L999 + li.d TEMP, 1 + slli.d TEMP, TEMP, BASE_SHIFT + slli.d INCX, INCX, BASE_SHIFT + bne INCX, TEMP, .L20 + xvld VM0, X, 0 + addi.d i0, i0, 1 + srai.d I, N, 3 + bge $r0, I, .L21 + slli.d i0, i0, 2 //4 + xvreplgr2vr.d VINC4, i0 + slli.d i0, i0, 1 //8 + xvreplgr2vr.d VINC8, i0 + addi.d i0, i0, -15 + xvinsgr2vr.d VI1, i0, 0 //initialize the index value for vectorization + addi.d i0, i0, 1 + xvinsgr2vr.d VI1, i0, 1 + addi.d i0, i0, 1 + xvinsgr2vr.d VI1, i0, 2 + addi.d i0, i0, 1 + xvinsgr2vr.d VI1, i0, 3 + addi.d i0, i0, 5 + xvinsgr2vr.d VI0, i0, 0 //1 + addi.d i0, i0, 1 + xvinsgr2vr.d VI0, i0, 1 //2 + addi.d i0, i0, 1 + xvinsgr2vr.d VI0, i0, 2 //3 + addi.d i0, i0, 1 + xvinsgr2vr.d VI0, i0, 3 //4 + .align 3 + +.L10: + xvld VX0, X, 0 * SIZE + xvadd.d VI1, VI1, VINC8 + xvld VX1, X, 4 * SIZE + xvadd.d VI2, VI1, VINC4 + xvfmaxa.d VM1, VX0, VX1 + xvfcmp.ceq.d VT0, VX0, VM1 + addi.d I, I, -1 + xvbitsel.v VI2, VI2, VI1, VT0 + xvfmaxa.d VM1, VM0, VM1 + xvfcmp.ceq.d VT0, VM0, VM1 + addi.d X, X, 8 * SIZE + xvbitsel.v VM0, VM1, VM0, VT0 + xvbitsel.v VI0, VI2, VI0, VT0 + blt $r0, I, .L10 + .align 3 + +.L15: + xvpickve.d VI1, VI0, 0 + xvpickve.d VI2, VI0, 1 + xvpickve.d VI3, VI0, 2 + xvpickve.d VI4, VI0, 3 + xvpickve.d x1, VM0, 0 + xvpickve.d x2, VM0, 1 + xvpickve.d x3, VM0, 2 + xvpickve.d x4, VM0, 3 + xvfmaxa.d VM1, x1, x2 + xvfcmp.ceq.d VT0, x1, VM1 + xvbitsel.v VINC4, VI2, VI1, VT0 + xvfmaxa.d VM0, x4, x3 + xvfcmp.ceq.d VT0, x3, VM0 + xvbitsel.v VINC8, VI4, VI3, VT0 + xvfmaxa.d VM0, VM0, VM1 + xvfcmp.ceq.d VT0, VM0, VM1 + xvbitsel.v VI0, VINC8, VINC4, VT0 + li.d TEMP, 1 //处理尾数相等时取最小序号 + movgr2fr.d $f17, TEMP + ffint.d.l $f17, $f17 + xvfcmp.ceq.d VT0, VM0, x1 + fcmp.ceq.d $fcc0, $f23, $f17 + bceqz $fcc0, .L26 + xvfcmp.clt.d VT0, VI1, VI0 + xvbitsel.v VI0, VI0, VI1, VT0 + b .L26 + .align 3 + +.L20: // INCX!=1 + move TEMP, X + addi.d i0, i0, 1 + ld.d t1, TEMP, 0 * SIZE + add.d TEMP, TEMP, INCX + xvinsgr2vr.d VM0, t1, 0 + srai.d I, N, 3 + bge $r0, I, .L21 + ld.d t2, TEMP, 0 * SIZE + add.d TEMP, TEMP, INCX + ld.d t3, TEMP, 0 * SIZE + add.d TEMP, TEMP, INCX + ld.d t4, TEMP, 0 * SIZE + add.d TEMP, TEMP, INCX + xvinsgr2vr.d VM0, t2, 1 + xvinsgr2vr.d VM0, t3, 2 + xvinsgr2vr.d VM0, t4, 3 + slli.d i0, i0, 2 //4 + xvreplgr2vr.d VINC4, i0 + slli.d i0, i0, 1 //8 + xvreplgr2vr.d VINC8, i0 + addi.d i0, i0, -15 + xvinsgr2vr.d VI1, i0, 0 //initialize the index value for vectorization + addi.d i0, i0, 1 + xvinsgr2vr.d VI1, i0, 1 + addi.d i0, i0, 1 + xvinsgr2vr.d VI1, i0, 2 + addi.d i0, i0, 1 + xvinsgr2vr.d VI1, i0, 3 + addi.d i0, i0, 5 + xvinsgr2vr.d VI0, i0, 0 //1 + addi.d i0, i0, 1 + xvinsgr2vr.d VI0, i0, 1 //2 + addi.d i0, i0, 1 + xvinsgr2vr.d VI0, i0, 2 //3 + addi.d i0, i0, 1 + xvinsgr2vr.d VI0, i0, 3 //4 + .align 3 + +.L24: + ld.d t1, X, 0 * SIZE + add.d X, X, INCX + ld.d t2, X, 0 * SIZE + add.d X, X, INCX + ld.d t3, X, 0 * SIZE + add.d X, X, INCX + ld.d t4, X, 0 * SIZE + add.d X, X, INCX + xvinsgr2vr.d VX0, t1, 0 + xvinsgr2vr.d VX0, t2, 1 + xvinsgr2vr.d VX0, t3, 2 + xvinsgr2vr.d VX0, t4, 3 + xvadd.d VI1, VI1, VINC8 + ld.d t1, X, 0 * SIZE + add.d X, X, INCX + ld.d t2, X, 0 * SIZE + add.d X, X, INCX + ld.d t3, X, 0 * SIZE + add.d X, X, INCX + ld.d t4, X, 0 * SIZE + add.d X, X, INCX + xvinsgr2vr.d VX1, t1, 0 + xvinsgr2vr.d VX1, t2, 1 + xvinsgr2vr.d VX1, t3, 2 + xvinsgr2vr.d VX1, t4, 3 + xvadd.d VI2, VI1, VINC4 + xvfmaxa.d VM1, VX0, VX1 + xvfcmp.ceq.d VT0, VX0, VM1 + addi.d I, I, -1 + xvbitsel.v VI2, VI2, VI1, VT0 + xvfmaxa.d VM1, VM0, VM1 + xvfcmp.ceq.d VT0, VM0, VM1 + xvbitsel.v VM0, VM1, VM0, VT0 + xvbitsel.v VI0, VI2, VI0, VT0 + blt $r0, I, .L24 + .align 3 + +.L25: + xvpickve.d VI1, VI0, 0 + xvpickve.d VI2, VI0, 1 + xvpickve.d VI3, VI0, 2 + xvpickve.d VI4, VI0, 3 + xvpickve.d x1, VM0, 0 + xvpickve.d x2, VM0, 1 + xvpickve.d x3, VM0, 2 + xvpickve.d x4, VM0, 3 + xvfmaxa.d VM1, x1, x2 + xvfcmp.ceq.d VT0, x1, VM1 + xvbitsel.v VINC4, VI2, VI1, VT0 + xvfmaxa.d VM0, x4, x3 + xvfcmp.ceq.d VT0, x3, VM0 + xvbitsel.v VINC8, VI4, VI3, VT0 + xvfmaxa.d VM0, VM0, VM1 + xvfcmp.ceq.d VT0, VM0, VM1 + xvbitsel.v VI0, VINC8, VINC4, VT0 + li.d TEMP, 1 //处理尾数相等时取最小序号 + movgr2fr.d $f17, TEMP + ffint.d.l $f17, $f17 + xvfcmp.ceq.d VT0, VM0, x1 + fcmp.ceq.d $fcc0, $f23, $f17 + bceqz $fcc0, .L26 + xvfcmp.clt.d VT0, VI1, VI0 + xvbitsel.v VI0, VI0, VI1, VT0 + .align 3 + +.L26: + xvfcmp.ceq.d VT0, VM0, x2 + fcmp.ceq.d $fcc0, $f23, $f17 + bceqz $fcc0, .L27 + xvfcmp.clt.d VT0, VI2, VI0 + xvbitsel.v VI0, VI0, VI2, VT0 + .align 3 + +.L27: + xvfcmp.ceq.d VT0, VM0, x3 + fcmp.ceq.d $fcc0, $f23, $f17 + bceqz $fcc0, .L28 + xvfcmp.clt.d VT0, VI3, VI0 + xvbitsel.v VI0, VI0, VI3, VT0 + .align 3 + +.L28: + xvfcmp.ceq.d VT0, VM0, x4 + fcmp.ceq.d $fcc0, $f23, $f17 + bceqz $fcc0, .L29 + xvfcmp.clt.d VT0, VI4, VI0 + xvbitsel.v VI0, VI0, VI4, VT0 + .align 3 + +.L29: + movfr2gr.d i0, $f20 + .align 3 + +.L21: //N<8 + andi I, N, 7 + bge $r0, I, .L999 + srai.d i1, N, 3 + slli.d i1, i1, 3 + addi.d i1, i1, 1 //current index + movgr2fr.d $f21, i1 + movgr2fr.d $f20, i0 + .align 3 + +.L22: + fld.d $f9, X, 0 + addi.d I, I, -1 + xvfmaxa.d VM1, x1, VM0 + xvfcmp.ceq.d VT0, VM0, VM1 + add.d X, X, INCX + xvbitsel.v VM0, VM1, VM0, VT0 + xvbitsel.v VI0, VI1, VI0, VT0 + addi.d i1, i1, 1 + movgr2fr.d $f21, i1 + blt $r0, I, .L22 + movfr2gr.d i0, $f20 + .align 3 + +.L999: + move $r4, $r17 + jirl $r0, $r1, 0x0 + .align 3 + + EPILOGUE diff --git a/kernel/loongarch64/idamax_lsx.S b/kernel/loongarch64/idamax_lsx.S new file mode 100644 index 000000000..fb2d5bac1 --- /dev/null +++ b/kernel/loongarch64/idamax_lsx.S @@ -0,0 +1,267 @@ +#define ASSEMBLER + +#include "common.h" + +#define N $r4 +#define X $r5 +#define INCX $r6 +#define I $r12 +#define t1 $r13 +#define t2 $r15 +#define t3 $r18 +#define t4 $r16 +#define i0 $r17 +#define i1 $r14 +#define TEMP $r19 +#define x1 $vr9 +#define x2 $vr10 +#define x3 $vr11 +#define x4 $vr12 +#define VX0 $vr13 +#define VX1 $vr14 +#define VM0 $vr15 +#define VM1 $vr16 +#define VINC2 $vr17 +#define VINC4 $vr18 +#define VI0 $vr20 +#define VI1 $vr21 +#define VI2 $vr22 +#define VI3 $vr8 +#define VI4 $vr19 +#define VT0 $vr23 + + PROLOGUE + li.d i0, 0 + bge $r0, N, .L999 + bge $r0, INCX, .L999 + li.d TEMP, 1 + slli.d TEMP, TEMP, BASE_SHIFT + slli.d INCX, INCX, BASE_SHIFT + bne INCX, TEMP, .L20 + vld VM0, X, 0 + addi.d i0, i0, 1 + srai.d I, N, 3 + bge $r0, I, .L11 + slli.d i0, i0, 1 //2 + vreplgr2vr.d VINC2, i0 + slli.d i0, i0, 1 //4 + vreplgr2vr.d VINC4, i0 + addi.d i0, i0, -7 + vinsgr2vr.d VI1, i0, 0 //initialize the index value for vectorization + addi.d i0, i0, 1 + vinsgr2vr.d VI1, i0, 1 + addi.d i0, i0, 3 + vinsgr2vr.d VI0, i0, 0 //1 + addi.d i0, i0, 1 + vinsgr2vr.d VI0, i0, 1 //2 + .align 3 + +.L10: + vld VX0, X, 0 * SIZE + vadd.d VI1, VI1, VINC4 + vld VX1, X, 2 * SIZE + vadd.d VI2, VI1, VINC2 + vfmaxa.d x1, VX0, VX1 + vfcmp.ceq.d VT0, VX0, x1 + vbitsel.v x2, VI2, VI1, VT0 + vld VX0, X, 4 * SIZE + vadd.d VI1, VI2, VINC2 + vld VX1, X, 6 * SIZE + vadd.d VI2, VI1, VINC2 + vfmaxa.d x3, VX0, VX1 + vfcmp.ceq.d VT0, VX0, x3 + vbitsel.v x4, VI2, VI1, VT0 + vfmaxa.d x3, x1, x3 + vfcmp.ceq.d VT0, x1, x3 + vbitsel.v x2, x4, x2, VT0 + vfmaxa.d VM1, VM0, x3 + vfcmp.ceq.d VT0, VM0, VM1 + vbitsel.v VM0, VM1, VM0, VT0 + vbitsel.v VI0, x2, VI0, VT0 + addi.d I, I, -1 + addi.d X, X, 8 * SIZE + blt $r0, I, .L10 + .align 3 + +.L15: + vreplvei.d VI1, VI0, 0 + vreplvei.d VI2, VI0, 1 + vreplvei.d x1, VM0, 0 + vreplvei.d x2, VM0, 1 + li.d TEMP, 1 //处理尾数相等时取最小序号 + movgr2fr.d $f17, TEMP + ffint.d.l $f17, $f17 + vfcmp.ceq.d VT0, x2, x1 + fcmp.ceq.d $fcc0, $f23, $f17 + bceqz $fcc0, .L16 + vfcmp.clt.d VT0, VI1, VI0 + vbitsel.v VI0, VI0, VI1, VT0 + b .L17 + .align 3 + +.L16: + vfmaxa.d VM0, x1, x2 + vfcmp.ceq.d VT0, x1, VM0 + vbitsel.v VI0, VI2, VI1, VT0 + .align 3 + +.L17: + movfr2gr.d i0, $f20 + .align 3 + +.L11: //INCX==1 and N<8 + andi I, N, 7 + bge $r0, I, .L14 + srai.d i1, N, 3 + slli.d i1, i1, 3 + addi.d i1, i1, 1 //current index + movgr2fr.d $f21, i1 + movgr2fr.d $f20, i0 + .align 3 + +.L13: + fld.d $f9, X, 0 + vfmaxa.d VM1, x1, VM0 + vfcmp.ceq.d VT0, VM0, VM1 + vbitsel.v VM0, VM1, VM0, VT0 + vbitsel.v VI0, VI1, VI0, VT0 + addi.d I, I, -1 + addi.d i1, i1, 1 + addi.d X, X, SIZE + movgr2fr.d $f21, i1 + blt $r0, I, .L13 + movfr2gr.d i0, $f20 + .align 3 + +.L14: + move $r4, $r17 + jirl $r0, $r1, 0x0 + .align 3 + +.L20: // INCX!=1 + move TEMP, X + addi.d i0, i0, 1 + ld.d t1, TEMP, 0 * SIZE + add.d TEMP, TEMP, INCX + vinsgr2vr.d VM0, t1, 0 + srai.d I, N, 3 + bge $r0, I, .L21 + ld.d t2, TEMP, 0 * SIZE + add.d TEMP, TEMP, INCX + vinsgr2vr.d VM0, t2, 1 + slli.d i0, i0, 1 //2 + vreplgr2vr.d VINC2, i0 + slli.d i0, i0, 1 //4 + vreplgr2vr.d VINC4, i0 + addi.d i0, i0, -7 + vinsgr2vr.d VI1, i0, 0 //initialize the index value for vectorization + addi.d i0, i0, 1 + vinsgr2vr.d VI1, i0, 1 + addi.d i0, i0, 3 + vinsgr2vr.d VI0, i0, 0 //1 + addi.d i0, i0, 1 + vinsgr2vr.d VI0, i0, 1 //2 + .align 3 + +.L24: + ld.d t1, X, 0 * SIZE + add.d X, X, INCX + vinsgr2vr.d VX0, t1, 0 + ld.d t2, X, 0 * SIZE + add.d X, X, INCX + vinsgr2vr.d VX0, t2, 1 + vadd.d VI1, VI1, VINC4 + ld.d t1, X, 0 * SIZE + add.d X, X, INCX + vinsgr2vr.d VX1, t1, 0 + ld.d t2, X, 0 * SIZE + add.d X, X, INCX + vinsgr2vr.d VX1, t2, 1 + vadd.d VI2, VI1, VINC2 + vfmaxa.d x1, VX0, VX1 + vfcmp.ceq.d VT0, VX0, x1 + vbitsel.v x2, VI2, VI1, VT0 + ld.d t1, X, 0 * SIZE + add.d X, X, INCX + vinsgr2vr.d VX0, t1, 0 + ld.d t2, X, 0 * SIZE + add.d X, X, INCX + vinsgr2vr.d VX0, t2, 1 + vadd.d VI1, VI2, VINC2 + ld.d t1, X, 0 * SIZE + add.d X, X, INCX + vinsgr2vr.d VX1, t1, 0 + ld.d t2, X, 0 * SIZE + add.d X, X, INCX + vinsgr2vr.d VX1, t2, 1 + vadd.d VI2, VI1, VINC2 + vfmaxa.d x3, VX0, VX1 + vfcmp.ceq.d VT0, VX0, x3 + vbitsel.v x4, VI2, VI1, VT0 + vfmaxa.d x3, x1, x3 + vfcmp.ceq.d VT0, x1, x3 + vbitsel.v x2, x4, x2, VT0 + vfmaxa.d VM1, VM0, x3 + vbitsel.v VM0, VM1, VM0, VT0 + vfcmp.ceq.d VT0, VM0, VM1 + vbitsel.v VI0, x2, VI0, VT0 + addi.d I, I, -1 + blt $r0, I, .L24 + .align 3 + +.L25: + vreplvei.d VI1, VI0, 0 + vreplvei.d VI2, VI0, 1 + vreplvei.d x1, VM0, 0 + vreplvei.d x2, VM0, 1 + li.d TEMP, 1 //处理尾数相等时取最小序号 + movgr2fr.d $f17, TEMP + ffint.d.l $f17, $f17 + vfcmp.ceq.d VT0, x2, x1 + fcmp.ceq.d $fcc0, $f23, $f17 + bceqz $fcc0, .L26 + vfcmp.clt.d VT0, VI1, VI0 + vbitsel.v VI0, VI0, VI1, VT0 + b .L27 + .align 3 + +.L26: + vfmaxa.d VM0, x1, x2 + vfcmp.ceq.d VT0, x1, VM0 + vbitsel.v VI0, VI2, VI1, VT0 + .align 3 + +.L27: + movfr2gr.d i0, $f20 + .align 3 + +.L21: // N<8 + andi I, N, 7 + bge $r0, I, .L999 + srai.d i1, N, 3 + slli.d i1, i1, 3 + addi.d i1, i1, 1 //current index + movgr2fr.d $f21, i1 + movgr2fr.d $f20, i0 + .align 3 + +.L22: + fld.d $f9, X, 0 + vfmaxa.d VM1, x1, VM0 + vfcmp.ceq.d VT0, VM0, VM1 + vbitsel.v VM0, VM1, VM0, VT0 + vbitsel.v VI0, VI1, VI0, VT0 + addi.d I, I, -1 + addi.d i1, i1, 1 + add.d X, X, INCX + movgr2fr.d $f21, i1 + blt $r0, I, .L22 + movfr2gr.d i0, $f20 + .align 3 + +.L999: + move $r4, $r17 + jirl $r0, $r1, 0x0 + .align 3 + + EPILOGUE diff --git a/kernel/loongarch64/isamax_lasx.S b/kernel/loongarch64/isamax_lasx.S new file mode 100644 index 000000000..2800b1d43 --- /dev/null +++ b/kernel/loongarch64/isamax_lasx.S @@ -0,0 +1,378 @@ +#define ASSEMBLER + +#include "common.h" + +#define N $r4 +#define X $r5 +#define INCX $r6 +#define I $r12 +#define t1 $r13 +#define t2 $r15 +#define t3 $r18 +#define t4 $r16 +#define i0 $r17 +#define i1 $r14 +#define TEMP $r19 +#define x1 $xr9 +#define x2 $xr10 +#define x3 $xr11 +#define x4 $xr12 +#define VX0 $xr13 +#define VX1 $xr14 +#define VM0 $xr15 +#define VM1 $xr16 +#define VINC4 $xr17 +#define VINC8 $xr18 +#define VI0 $xr20 +#define VI1 $xr21 +#define VI2 $xr22 +#define VI3 $xr8 +#define VI4 $xr19 +#define VT0 $xr23 + + PROLOGUE + li.d i0, 0 + bge $r0, N, .L999 + bge $r0, INCX, .L999 + li.d TEMP, 1 + slli.d TEMP, TEMP, BASE_SHIFT + slli.d INCX, INCX, BASE_SHIFT + bne INCX, TEMP, .L20 + xvld VM0, X, 0 + addi.w i0, i0, 1 + srai.d I, N, 3 + bge $r0, I, .L21 + slli.w i0, i0, 3 //8 + xvreplgr2vr.w VINC8, i0 + addi.w i0, i0, -15 + xvinsgr2vr.w VI1, i0, 0 //initialize the index value for vectorization + addi.w i0, i0, 1 + xvinsgr2vr.w VI1, i0, 1 + addi.w i0, i0, 1 + xvinsgr2vr.w VI1, i0, 2 + addi.w i0, i0, 1 + xvinsgr2vr.w VI1, i0, 3 + addi.w i0, i0, 1 + xvinsgr2vr.w VI1, i0, 4 + addi.w i0, i0, 1 + xvinsgr2vr.w VI1, i0, 5 + addi.w i0, i0, 1 + xvinsgr2vr.w VI1, i0, 6 + addi.w i0, i0, 1 + xvinsgr2vr.w VI1, i0, 7 + addi.w i0, i0, 1 + xvinsgr2vr.w VI0, i0, 0 //1 + addi.w i0, i0, 1 + xvinsgr2vr.w VI0, i0, 1 //2 + addi.w i0, i0, 1 + xvinsgr2vr.w VI0, i0, 2 //3 + addi.w i0, i0, 1 + xvinsgr2vr.w VI0, i0, 3 //4 + addi.w i0, i0, 1 + xvinsgr2vr.w VI0, i0, 4 //5 + addi.w i0, i0, 1 + xvinsgr2vr.w VI0, i0, 5 //6 + addi.w i0, i0, 1 + xvinsgr2vr.w VI0, i0, 6 //7 + addi.w i0, i0, 1 + xvinsgr2vr.w VI0, i0, 7 //8 + .align 3 + +.L10: + xvld VX0, X, 0 * SIZE + addi.d I, I, -1 + xvadd.w VI1, VI1, VINC8 + xvfmaxa.s VM1, VX0, VM0 + xvfcmp.ceq.s VT0, VM0, VM1 + addi.d X, X, 8 * SIZE + xvbitsel.v VM0, VM1, VM0, VT0 + xvbitsel.v VI0, VI1, VI0, VT0 + blt $r0, I, .L10 + .align 3 + +.L15: + xvxor.v VX0, VX0, VX0 + xvor.v VX0, VI0, VX0 + xvxor.v VX1, VX1, VX1 + xvor.v VX1, VM0, VX1 + xvpickve.w VI1, VI0, 0 + xvpickve.w VI2, VI0, 1 + xvpickve.w VI3, VI0, 2 + xvpickve.w VI4, VI0, 3 + xvpickve.w x1, VM0, 0 + xvpickve.w x2, VM0, 1 + xvpickve.w x3, VM0, 2 + xvpickve.w x4, VM0, 3 + xvfmaxa.s VM1, x1, x2 + xvfcmp.ceq.s VT0, x1, VM1 + xvbitsel.v VINC4, VI2, VI1, VT0 + xvfmaxa.s VM0, x3, x4 + xvfcmp.ceq.s VT0, x3, VM0 + xvbitsel.v VINC8, VI4, VI3, VT0 + xvfmaxa.s VM0, VM0, VM1 + xvfcmp.ceq.s VT0, VM0, VM1 + xvbitsel.v VI0, VINC8, VINC4, VT0 + li.d TEMP, 1 //处理尾数相等时取最小序号 + movgr2fr.w $f17, TEMP + ffint.s.w $f17, $f17 + xvfcmp.ceq.s VT0, VM0, x1 + fcmp.ceq.s $fcc0, $f23, $f17 + bceqz $fcc0, .L26 + xvfcmp.clt.s VT0, VI1, VI0 + xvbitsel.v VI0, VI0, VI1, VT0 + b .L26 + .align 3 + +.L20: // INCX!=1 + move TEMP, X + addi.w i0, i0, 1 + ld.w t1, TEMP, 0 * SIZE + add.d TEMP, TEMP, INCX + xvinsgr2vr.w VM0, t1, 0 + srai.d I, N, 3 + bge $r0, I, .L21 + ld.w t2, TEMP, 0 * SIZE + add.d TEMP, TEMP, INCX + ld.w t3, TEMP, 0 * SIZE + add.d TEMP, TEMP, INCX + ld.w t4, TEMP, 0 * SIZE + add.d TEMP, TEMP, INCX + xvinsgr2vr.w VM0, t2, 1 + xvinsgr2vr.w VM0, t3, 2 + xvinsgr2vr.w VM0, t4, 3 + ld.w t1, TEMP, 0 * SIZE + add.d TEMP, TEMP, INCX + ld.w t2, TEMP, 0 * SIZE + add.d TEMP, TEMP, INCX + ld.w t3, TEMP, 0 * SIZE + add.d TEMP, TEMP, INCX + ld.w t4, TEMP, 0 * SIZE + add.d TEMP, TEMP, INCX + xvinsgr2vr.w VM0, t1, 4 + xvinsgr2vr.w VM0, t2, 5 + xvinsgr2vr.w VM0, t3, 6 + xvinsgr2vr.w VM0, t4, 7 + slli.w i0, i0, 3 //8 + xvreplgr2vr.w VINC8, i0 + addi.w i0, i0, -15 + xvinsgr2vr.w VI1, i0, 0 //initialize the index value for vectorization + addi.w i0, i0, 1 + xvinsgr2vr.w VI1, i0, 1 + addi.w i0, i0, 1 + xvinsgr2vr.w VI1, i0, 2 + addi.w i0, i0, 1 + xvinsgr2vr.w VI1, i0, 3 + addi.w i0, i0, 1 + xvinsgr2vr.w VI1, i0, 4 + addi.w i0, i0, 1 + xvinsgr2vr.w VI1, i0, 5 + addi.w i0, i0, 1 + xvinsgr2vr.w VI1, i0, 6 + addi.w i0, i0, 1 + xvinsgr2vr.w VI1, i0, 7 + addi.w i0, i0, 1 + xvinsgr2vr.w VI0, i0, 0 //1 + addi.w i0, i0, 1 + xvinsgr2vr.w VI0, i0, 1 //2 + addi.w i0, i0, 1 + xvinsgr2vr.w VI0, i0, 2 //3 + addi.w i0, i0, 1 + xvinsgr2vr.w VI0, i0, 3 //4 + addi.w i0, i0, 1 + xvinsgr2vr.w VI0, i0, 4 //5 + addi.w i0, i0, 1 + xvinsgr2vr.w VI0, i0, 5 //6 + addi.w i0, i0, 1 + xvinsgr2vr.w VI0, i0, 6 //7 + addi.w i0, i0, 1 + xvinsgr2vr.w VI0, i0, 7 //8 + .align 3 + +.L24: + ld.w t1, X, 0 * SIZE + add.d X, X, INCX + ld.w t2, X, 0 * SIZE + add.d X, X, INCX + ld.w t3, X, 0 * SIZE + add.d X, X, INCX + ld.w t4, X, 0 * SIZE + add.d X, X, INCX + xvinsgr2vr.w VX0, t1, 0 + xvinsgr2vr.w VX0, t2, 1 + xvinsgr2vr.w VX0, t3, 2 + xvinsgr2vr.w VX0, t4, 3 + ld.w t1, X, 0 * SIZE + add.d X, X, INCX + ld.w t2, X, 0 * SIZE + add.d X, X, INCX + ld.w t3, X, 0 * SIZE + add.d X, X, INCX + ld.w t4, X, 0 * SIZE + add.d X, X, INCX + xvinsgr2vr.w VX0, t1, 4 + xvinsgr2vr.w VX0, t2, 5 + xvinsgr2vr.w VX0, t3, 6 + xvinsgr2vr.w VX0, t4, 7 + xvadd.w VI1, VI1, VINC8 + xvfmaxa.s VM1, VX0, VM0 + xvfcmp.ceq.s VT0, VM1, VM0 + addi.d I, I, -1 + xvbitsel.v VM0, VM1, VM0, VT0 + xvbitsel.v VI0, VI1, VI0, VT0 + blt $r0, I, .L24 + .align 3 + +.L25: + xvxor.v VX0, VX0, VX0 + xvor.v VX0, VI0, VX0 + xvxor.v VX1, VX1, VX1 + xvor.v VX1, VM0, VX1 + xvpickve.w VI1, VI0, 0 + xvpickve.w VI2, VI0, 1 + xvpickve.w VI3, VI0, 2 + xvpickve.w VI4, VI0, 3 + xvpickve.w x1, VM0, 0 + xvpickve.w x2, VM0, 1 + xvpickve.w x3, VM0, 2 + xvpickve.w x4, VM0, 3 + xvfmaxa.s VM1, x1, x2 + xvfcmp.ceq.s VT0, x1, VM1 + xvbitsel.v VINC4, VI2, VI1, VT0 + xvfmaxa.s VM0, x3, x4 + xvfcmp.ceq.s VT0, x3, VM0 + xvbitsel.v VINC8, VI3, VI4, VT0 + xvfmaxa.s VM0, VM0, VM1 + xvfcmp.ceq.s VT0, VM0, VM1 + xvbitsel.v VM0, VM0, VM1, VT0 + xvbitsel.v VI0, VINC8, VINC4, VT0 + li.d TEMP, 1 //处理尾数相等时取最小序号 + movgr2fr.w $f17, TEMP + ffint.s.w $f17, $f17 + xvfcmp.ceq.s VT0, VM0, x1 + fcmp.ceq.s $fcc0, $f23, $f17 + bceqz $fcc0, .L26 + xvfcmp.clt.s VT0, VI1, VI0 + xvbitsel.v VI0, VI0, VI1, VT0 + .align 3 + +.L26: + xvfcmp.ceq.s VT0, VM0, x2 + fcmp.ceq.s $fcc0, $f23, $f17 + bceqz $fcc0, .L27 + xvfcmp.clt.s VT0, VI2, VI0 + xvbitsel.v VI0, VI0, VI2, VT0 + .align 3 + +.L27: + xvfcmp.ceq.s VT0, VM0, x3 + fcmp.ceq.s $fcc0, $f23, $f17 + bceqz $fcc0, .L28 + xvfcmp.clt.s VT0, VI3, VI0 + xvbitsel.v VI0, VI0, VI3, VT0 + .align 3 + +.L28: + xvfcmp.ceq.s VT0, VM0, x4 + fcmp.ceq.s $fcc0, $f23, $f17 + bceqz $fcc0, .L29 + xvfcmp.clt.s VT0, VI4, VI0 + xvbitsel.v VI0, VI0, VI4, VT0 + .align 3 + +.L29: + fmov.s $f16, $f20 + .align 3 + +.L252: + xvxor.v VI0, VI0, VI0 + xvor.v VI0, VI0, VX0 + fmov.s $f13, $f15 + xvxor.v VM0, VM0, VM0 + xvor.v VM0, VM0, VX1 + xvpickve.w VI1, VI0, 4 + xvpickve.w VI2, VI0, 5 + xvpickve.w VI3, VI0, 6 + xvpickve.w VI4, VI0, 7 + xvpickve.w x1, VM0, 4 + xvpickve.w x2, VM0, 5 + xvpickve.w x3, VM0, 6 + xvpickve.w x4, VM0, 7 + xvfmaxa.s VM1, x1, x2 + xvfcmp.ceq.s VT0, x1, VM1 + xvbitsel.v VINC4, VI2, VI1, VT0 + xvfmaxa.s VM0, x3, x4 + xvfcmp.ceq.s VT0, x3, VM0 + xvbitsel.v VINC8, VI4, VI3, VT0 + xvfmaxa.s VM0, VM0, VM1 + xvfcmp.ceq.s VT0, VM0, VM1 + xvbitsel.v VI0, VINC8, VINC4, VT0 + li.d TEMP, 1 //处理尾数相等时取最小序号 + movgr2fr.w $f17, TEMP + ffint.s.w $f17, $f17 + xvfcmp.ceq.s VT0, VM0, x1 + fcmp.ceq.s $fcc0, $f23, $f17 + bceqz $fcc0, .L262 + xvfcmp.clt.s VT0, VI1, VI0 + xvbitsel.v VI0, VI0, VI1, VT0 + .align 3 + +.L262: + xvfcmp.ceq.s VT0, VM0, x2 + fcmp.ceq.s $fcc0, $f23, $f17 + bceqz $fcc0, .L272 + xvfcmp.clt.s VT0, VI2, VI0 + xvbitsel.v VI0, VI0, VI2, VT0 + .align 3 + +.L272: + xvfcmp.ceq.s VT0, VM0, x3 + fcmp.ceq.s $fcc0, $f23, $f17 + bceqz $fcc0, .L282 + xvfcmp.clt.s VT0, VI3, VI0 + xvbitsel.v VI0, VI0, VI3, VT0 + .align 3 + +.L282: + xvfcmp.ceq.s VT0, VM0, x4 + fcmp.ceq.s $fcc0, $f23, $f17 + bceqz $fcc0, .L292 + xvfcmp.clt.s VT0, VI4, VI0 + xvbitsel.v VI0, VI0, VI4, VT0 + .align 3 + +.L292: + xvfmaxa.s VM0, VX0, VM0 + xvfcmp.ceq.s VT0, VM0, VX0 + xvbitsel.v VI0, VI0, VI1, VT0 + movfr2gr.s i0, $f20 + +.L21: // N<8 + andi I, N, 7 + bge $r0, I, .L999 + srai.d i1, N, 3 + slli.d i1, i1, 3 + addi.d i1, i1, 1 //current index + movgr2fr.d $f21, i1 + movgr2fr.d $f20, i0 + .align 3 + +.L22: + fld.s $f9, X, 0 + addi.d I, I, -1 + xvfmaxa.s VM1, x1, VM0 + xvfcmp.ceq.s VT0, VM0, VM1 + add.d X, X, INCX + xvbitsel.v VM0, VM1, VM0, VT0 + xvbitsel.v VI0, VI1, VI0, VT0 + addi.d i1, i1, 1 + movgr2fr.d $f21, i1 + blt $r0, I, .L22 + movfr2gr.s i0, $f20 + .align 3 + +.L999: + move $r4, $r17 + jirl $r0, $r1, 0x0 + .align 3 + + EPILOGUE \ No newline at end of file diff --git a/kernel/loongarch64/isamax_lsx.S b/kernel/loongarch64/isamax_lsx.S new file mode 100644 index 000000000..a18aa7354 --- /dev/null +++ b/kernel/loongarch64/isamax_lsx.S @@ -0,0 +1,275 @@ +#define ASSEMBLER + +#include "common.h" + +#define N $r4 +#define X $r5 +#define INCX $r6 +#define I $r12 +#define t1 $r13 +#define t2 $r15 +#define t3 $r18 +#define t4 $r16 +#define i0 $r17 +#define i1 $r14 +#define TEMP $r19 +#define x1 $vr9 +#define x2 $vr10 +#define x3 $vr11 +#define x4 $vr12 +#define VX0 $vr13 +#define VX1 $vr14 +#define VM0 $vr15 +#define VM1 $vr16 +#define VINC4 $vr17 +#define VINC8 $vr18 +#define VI0 $vr20 +#define VI1 $vr21 +#define VI2 $vr22 +#define VI3 $vr8 +#define VI4 $vr19 +#define VT0 $vr23 + + PROLOGUE + li.d i0, 0 + bge $r0, N, .L999 + bge $r0, INCX, .L999 + li.d TEMP, 1 + slli.d TEMP, TEMP, BASE_SHIFT + slli.d INCX, INCX, BASE_SHIFT + bne INCX, TEMP, .L20 + vld VM0, X, 0 + addi.w i0, i0, 1 + srai.d I, N, 3 + bge $r0, I, .L21 + slli.w i0, i0, 2 //4 + vreplgr2vr.w VINC4, i0 + slli.w i0, i0, 1 //8 + vreplgr2vr.w VINC8, i0 + addi.w i0, i0, -15 + vinsgr2vr.w VI1, i0, 0 //initialize the index value for vectorization + addi.w i0, i0, 1 + vinsgr2vr.w VI1, i0, 1 + addi.w i0, i0, 1 + vinsgr2vr.w VI1, i0, 2 + addi.w i0, i0, 1 + vinsgr2vr.w VI1, i0, 3 + addi.w i0, i0, 5 + vinsgr2vr.w VI0, i0, 0 //1 + addi.w i0, i0, 1 + vinsgr2vr.w VI0, i0, 1 //2 + addi.w i0, i0, 1 + vinsgr2vr.w VI0, i0, 2 //3 + addi.w i0, i0, 1 + vinsgr2vr.w VI0, i0, 3 //4 + .align 3 + +.L10: + vld VX0, X, 0 * SIZE + vadd.w VI1, VI1, VINC8 + vld VX1, X, 4 * SIZE + vadd.w VI2, VI1, VINC4 + vfmaxa.s VM1, VX0, VX1 + vfcmp.ceq.s VT0, VX0, VM1 + addi.d I, I, -1 + vbitsel.v VI2, VI2, VI1, VT0 + vfmaxa.s VM1, VM0, VM1 + vfcmp.ceq.s VT0, VM0, VM1 + addi.d X, X, 8 * SIZE + vbitsel.v VM0, VM1, VM0, VT0 + vbitsel.v VI0, VI2, VI0, VT0 + blt $r0, I, .L10 + .align 3 + +.L15: + vreplvei.w VI1, VI0, 0 + vreplvei.w VI2, VI0, 1 + vreplvei.w VI3, VI0, 2 + vreplvei.w VI4, VI0, 3 + vreplvei.w x1, VM0, 0 + vreplvei.w x2, VM0, 1 + vreplvei.w x3, VM0, 2 + vreplvei.w x4, VM0, 3 + vfmaxa.s VM1, x1, x2 + vfcmp.ceq.s VT0, VM1, x1 + vbitsel.v VINC4, VI2, VI1, VT0 + vfmaxa.s VM0, x3, x4 + vfcmp.ceq.s VT0, x3, VM0 + vbitsel.v VINC8, VI4, VI3, VT0 + vfmaxa.s VM0, VM0, VM1 + vfcmp.ceq.s VT0, VM0, VM1 + vbitsel.v VI0, VINC8, VINC4, VT0 + li.d TEMP, 1 //处理尾数相等时取最小序号 + movgr2fr.w $f17, TEMP + ffint.s.w $f17, $f17 + vfcmp.ceq.s VT0, VM0, x1 + fcmp.ceq.s $fcc0, $f23, $f17 + bceqz $fcc0, .L26 + vfcmp.clt.s VT0, VI1, VI0 + vbitsel.v VI0, VI0, VI1, VT0 + b .L26 + .align 3 + +.L20: // INCX!=1 + move TEMP, X + addi.w i0, i0, 1 + ld.w t1, TEMP, 0 * SIZE + add.d TEMP, TEMP, INCX + vinsgr2vr.w VM0, t1, 0 + srai.d I, N, 3 + bge $r0, I, .L21 + ld.w t2, TEMP, 0 * SIZE + add.d TEMP, TEMP, INCX + ld.w t3, TEMP, 0 * SIZE + add.d TEMP, TEMP, INCX + ld.w t4, TEMP, 0 * SIZE + add.d TEMP, TEMP, INCX + vinsgr2vr.w VM0, t2, 1 + vinsgr2vr.w VM0, t3, 2 + vinsgr2vr.w VM0, t4, 3 + slli.w i0, i0, 2 //4 + vreplgr2vr.w VINC4, i0 + slli.w i0, i0, 1 //8 + vreplgr2vr.w VINC8, i0 + addi.w i0, i0, -15 + vinsgr2vr.w VI1, i0, 0 //initialize the index value for vectorization + addi.w i0, i0, 1 + vinsgr2vr.w VI1, i0, 1 + addi.w i0, i0, 1 + vinsgr2vr.w VI1, i0, 2 + addi.w i0, i0, 1 + vinsgr2vr.w VI1, i0, 3 + addi.w i0, i0, 5 + vinsgr2vr.w VI0, i0, 0 //1 + addi.w i0, i0, 1 + vinsgr2vr.w VI0, i0, 1 //2 + addi.w i0, i0, 1 + vinsgr2vr.w VI0, i0, 2 //3 + addi.w i0, i0, 1 + vinsgr2vr.w VI0, i0, 3 //4 + .align 3 + +.L24: + ld.w t1, X, 0 * SIZE + add.d X, X, INCX + ld.w t2, X, 0 * SIZE + add.d X, X, INCX + ld.w t3, X, 0 * SIZE + add.d X, X, INCX + ld.w t4, X, 0 * SIZE + add.d X, X, INCX + vinsgr2vr.w VX0, t1, 0 + vinsgr2vr.w VX0, t2, 1 + vinsgr2vr.w VX0, t3, 2 + vinsgr2vr.w VX0, t4, 3 + vadd.w VI1, VI1, VINC8 + ld.w t1, X, 0 * SIZE + add.d X, X, INCX + ld.w t2, X, 0 * SIZE + add.d X, X, INCX + ld.w t3, X, 0 * SIZE + add.d X, X, INCX + ld.w t4, X, 0 * SIZE + add.d X, X, INCX + vinsgr2vr.w VX1, t1, 0 + vinsgr2vr.w VX1, t2, 1 + vinsgr2vr.w VX1, t3, 2 + vinsgr2vr.w VX1, t4, 3 + vadd.w VI2, VI1, VINC4 + vfmaxa.s VM1, VX0, VX1 + vfcmp.ceq.s VT0, VX0, VM1 + vbitsel.v VI2, VI2, VI1, VT0 + vfmaxa.s VM1, VM0, VM1 + vfcmp.ceq.s VT0, VM0, VM1 + addi.d I, I, -1 + vbitsel.v VM0, VM1, VM0, VT0 + vbitsel.v VI0, VI2, VI0, VT0 + blt $r0, I, .L24 + .align 3 + +.L25: + vreplvei.w VI1, VI0, 0 + vreplvei.w VI2, VI0, 1 + vreplvei.w VI3, VI0, 2 + vreplvei.w VI4, VI0, 3 + vreplvei.w x1, VM0, 0 + vreplvei.w x2, VM0, 1 + vreplvei.w x3, VM0, 2 + vreplvei.w x4, VM0, 3 + vfmaxa.s VM1, x1, x2 + vfcmp.ceq.s VT0, VM1, x1 + vbitsel.v VINC4, VI2, VI1, VT0 + vfmaxa.s VM0, x3, x4 + vfcmp.ceq.s VT0, x3, VM0 + vbitsel.v VINC8, VI4, VI3, VT0 + vfmaxa.s VM0, VM0, VM1 + vfcmp.ceq.s VT0, VM0, VM1 + vbitsel.v VI0, VINC8, VINC4, VT0 + li.d TEMP, 1 //处理尾数相等时取最小序号 + movgr2fr.w $f17, TEMP + ffint.s.w $f17, $f17 + vfcmp.ceq.s VT0, VM0, x1 + fcmp.ceq.s $fcc0, $f23, $f17 + bceqz $fcc0, .L26 + vfcmp.clt.s VT0, VI1, VI0 + vbitsel.v VI0, VI0, VI1, VT0 + .align 3 + +.L26: + vfcmp.ceq.s VT0, VM0, x2 + fcmp.ceq.s $fcc0, $f23, $f17 + bceqz $fcc0, .L27 + vfcmp.clt.s VT0, VI2, VI0 + vbitsel.v VI0, VI0, VI2, VT0 + .align 3 + +.L27: + vfcmp.ceq.s VT0, VM0, x3 + fcmp.ceq.s $fcc0, $f23, $f17 + bceqz $fcc0, .L28 + vfcmp.clt.s VT0, VI3, VI0 + vbitsel.v VI0, VI0, VI3, VT0 + .align 3 + +.L28: + vfcmp.ceq.s VT0, VM0, x4 + fcmp.ceq.s $fcc0, $f23, $f17 + bceqz $fcc0, .L29 + vfcmp.clt.s VT0, VI4, VI0 + vbitsel.v VI0, VI0, VI4, VT0 + .align 3 + +.L29: + movfr2gr.s i0, $f20 + .align 3 + +.L21: //N<8 + andi I, N, 7 + bge $r0, I, .L999 + srai.d i1, N, 3 + slli.d i1, i1, 3 + addi.d i1, i1, 1 //current index + movgr2fr.d $f21, i1 + movgr2fr.d $f20, i0 + .align 3 + +.L22: + fld.s $f9, X, 0 + addi.d I, I, -1 + vfmaxa.s VM1, x1, VM0 + vfcmp.ceq.s VT0, VM0, VM1 + add.d X, X, INCX + vbitsel.v VM0, VM1, VM0, VT0 + vbitsel.v VI0, VI1, VI0, VT0 + addi.d i1, i1, 1 + movgr2fr.d $f21, i1 + blt $r0, I, .L22 + movfr2gr.s i0, $f20 + .align 3 + +.L999: + move $r4, $r17 + jirl $r0, $r1, 0x0 + .align 3 + + EPILOGUE From 49829b2b7db5d4ad78447c47391e8c0c96ffe803 Mon Sep 17 00:00:00 2001 From: yancheng Date: Thu, 7 Dec 2023 12:11:30 +0800 Subject: [PATCH 51/60] loongarch64: Add optimizations for iamin. --- kernel/loongarch64/KERNEL.LOONGSON2K1000 | 3 + kernel/loongarch64/KERNEL.LOONGSON3R5 | 3 + kernel/loongarch64/idamin_lasx.S | 275 +++++++++++++++++ kernel/loongarch64/idamin_lsx.S | 228 ++++++++++++++ kernel/loongarch64/isamin_lasx.S | 378 +++++++++++++++++++++++ kernel/loongarch64/isamin_lsx.S | 275 +++++++++++++++++ 6 files changed, 1162 insertions(+) create mode 100644 kernel/loongarch64/idamin_lasx.S create mode 100644 kernel/loongarch64/idamin_lsx.S create mode 100644 kernel/loongarch64/isamin_lasx.S create mode 100644 kernel/loongarch64/isamin_lsx.S diff --git a/kernel/loongarch64/KERNEL.LOONGSON2K1000 b/kernel/loongarch64/KERNEL.LOONGSON2K1000 index a4c8927ba..bff52ce93 100644 --- a/kernel/loongarch64/KERNEL.LOONGSON2K1000 +++ b/kernel/loongarch64/KERNEL.LOONGSON2K1000 @@ -28,4 +28,7 @@ IDMINKERNEL = idmin_lsx.S ISAMAXKERNEL = isamax_lsx.S IDAMAXKERNEL = idamax_lsx.S +ISAMINKERNEL = isamin_lsx.S +IDAMINKERNEL = idamin_lsx.S + endif diff --git a/kernel/loongarch64/KERNEL.LOONGSON3R5 b/kernel/loongarch64/KERNEL.LOONGSON3R5 index 835b027b8..a08598cc5 100644 --- a/kernel/loongarch64/KERNEL.LOONGSON3R5 +++ b/kernel/loongarch64/KERNEL.LOONGSON3R5 @@ -28,6 +28,9 @@ IDMINKERNEL = idmin_lasx.S ISAMAXKERNEL = isamax_lasx.S IDAMAXKERNEL = idamax_lasx.S +ISAMINKERNEL = isamin_lasx.S +IDAMINKERNEL = idamin_lasx.S + DGEMMKERNEL = dgemm_kernel_16x4.S DGEMMINCOPY = dgemm_ncopy_16.S DGEMMITCOPY = dgemm_tcopy_16.S diff --git a/kernel/loongarch64/idamin_lasx.S b/kernel/loongarch64/idamin_lasx.S new file mode 100644 index 000000000..6ef1e8903 --- /dev/null +++ b/kernel/loongarch64/idamin_lasx.S @@ -0,0 +1,275 @@ +#define ASSEMBLER + +#include "common.h" + +#define N $r4 +#define X $r5 +#define INCX $r6 +#define I $r12 +#define t1 $r13 +#define t2 $r15 +#define t3 $r18 +#define t4 $r16 +#define i0 $r17 +#define i1 $r14 +#define TEMP $r19 +#define x1 $xr9 +#define x2 $xr10 +#define x3 $xr11 +#define x4 $xr12 +#define VX0 $xr13 +#define VX1 $xr14 +#define VM0 $xr15 +#define VM1 $xr16 +#define VINC4 $xr17 +#define VINC8 $xr18 +#define VI0 $xr20 +#define VI1 $xr21 +#define VI2 $xr22 +#define VI3 $xr8 +#define VI4 $xr19 +#define VT0 $xr23 + + PROLOGUE + li.d i0, 0 + bge $r0, N, .L999 + bge $r0, INCX, .L999 + li.d TEMP, 1 + slli.d TEMP, TEMP, BASE_SHIFT + slli.d INCX, INCX, BASE_SHIFT + bne INCX, TEMP, .L20 + xvld VM0, X, 0 + addi.d i0, i0, 1 + srai.d I, N, 3 + bge $r0, I, .L21 + slli.d i0, i0, 2 //4 + xvreplgr2vr.d VINC4, i0 + slli.d i0, i0, 1 //8 + xvreplgr2vr.d VINC8, i0 + addi.d i0, i0, -15 + xvinsgr2vr.d VI1, i0, 0 //initialize the index value for vectorization + addi.d i0, i0, 1 + xvinsgr2vr.d VI1, i0, 1 + addi.d i0, i0, 1 + xvinsgr2vr.d VI1, i0, 2 + addi.d i0, i0, 1 + xvinsgr2vr.d VI1, i0, 3 + addi.d i0, i0, 5 + xvinsgr2vr.d VI0, i0, 0 //1 + addi.d i0, i0, 1 + xvinsgr2vr.d VI0, i0, 1 //2 + addi.d i0, i0, 1 + xvinsgr2vr.d VI0, i0, 2 //3 + addi.d i0, i0, 1 + xvinsgr2vr.d VI0, i0, 3 //4 + .align 3 + +.L10: + xvld VX0, X, 0 * SIZE + xvadd.d VI1, VI1, VINC8 + xvld VX1, X, 4 * SIZE + xvadd.d VI2, VI1, VINC4 + xvfmina.d VM1, VX0, VX1 + xvfcmp.ceq.d VT0, VX0, VM1 + addi.d I, I, -1 + xvbitsel.v VI2, VI2, VI1, VT0 + xvfmina.d VM1, VM0, VM1 + xvfcmp.ceq.d VT0, VM0, VM1 + addi.d X, X, 8 * SIZE + xvbitsel.v VM0, VM1, VM0, VT0 + xvbitsel.v VI0, VI2, VI0, VT0 + blt $r0, I, .L10 + .align 3 + +.L15: + xvpickve.d VI1, VI0, 0 + xvpickve.d VI2, VI0, 1 + xvpickve.d VI3, VI0, 2 + xvpickve.d VI4, VI0, 3 + xvpickve.d x1, VM0, 0 + xvpickve.d x2, VM0, 1 + xvpickve.d x3, VM0, 2 + xvpickve.d x4, VM0, 3 + xvfmina.d VM1, x1, x2 + xvfcmp.ceq.d VT0, x1, VM1 + xvbitsel.v VINC4, VI2, VI1, VT0 + xvfmina.d VM0, x4, x3 + xvfcmp.ceq.d VT0, x3, VM0 + xvbitsel.v VINC8, VI4, VI3, VT0 + xvfmina.d VM0, VM0, VM1 + xvfcmp.ceq.d VT0, VM0, VM1 + xvbitsel.v VI0, VINC8, VINC4, VT0 + li.d TEMP, 1 //处理尾数相等时取最小序号 + movgr2fr.d $f17, TEMP + ffint.d.l $f17, $f17 + xvfcmp.ceq.d VT0, VM0, x1 + fcmp.ceq.d $fcc0, $f23, $f17 + bceqz $fcc0, .L26 + xvfcmp.clt.d VT0, VI1, VI0 + xvbitsel.v VI0, VI0, VI1, VT0 + b .L26 + .align 3 + +.L20: // INCX!=1 + move TEMP, X + addi.d i0, i0, 1 + ld.d t1, TEMP, 0 * SIZE + add.d TEMP, TEMP, INCX + xvinsgr2vr.d VM0, t1, 0 + srai.d I, N, 3 + bge $r0, I, .L21 + ld.d t2, TEMP, 0 * SIZE + add.d TEMP, TEMP, INCX + ld.d t3, TEMP, 0 * SIZE + add.d TEMP, TEMP, INCX + ld.d t4, TEMP, 0 * SIZE + add.d TEMP, TEMP, INCX + xvinsgr2vr.d VM0, t2, 1 + xvinsgr2vr.d VM0, t3, 2 + xvinsgr2vr.d VM0, t4, 3 + slli.d i0, i0, 2 //4 + xvreplgr2vr.d VINC4, i0 + slli.d i0, i0, 1 //8 + xvreplgr2vr.d VINC8, i0 + addi.d i0, i0, -15 + xvinsgr2vr.d VI1, i0, 0 //initialize the index value for vectorization + addi.d i0, i0, 1 + xvinsgr2vr.d VI1, i0, 1 + addi.d i0, i0, 1 + xvinsgr2vr.d VI1, i0, 2 + addi.d i0, i0, 1 + xvinsgr2vr.d VI1, i0, 3 + addi.d i0, i0, 5 + xvinsgr2vr.d VI0, i0, 0 //1 + addi.d i0, i0, 1 + xvinsgr2vr.d VI0, i0, 1 //2 + addi.d i0, i0, 1 + xvinsgr2vr.d VI0, i0, 2 //3 + addi.d i0, i0, 1 + xvinsgr2vr.d VI0, i0, 3 //4 + .align 3 + +.L24: + ld.d t1, X, 0 * SIZE + add.d X, X, INCX + ld.d t2, X, 0 * SIZE + add.d X, X, INCX + ld.d t3, X, 0 * SIZE + add.d X, X, INCX + ld.d t4, X, 0 * SIZE + add.d X, X, INCX + xvinsgr2vr.d VX0, t1, 0 + xvinsgr2vr.d VX0, t2, 1 + xvinsgr2vr.d VX0, t3, 2 + xvinsgr2vr.d VX0, t4, 3 + xvadd.d VI1, VI1, VINC8 + ld.d t1, X, 0 * SIZE + add.d X, X, INCX + ld.d t2, X, 0 * SIZE + add.d X, X, INCX + ld.d t3, X, 0 * SIZE + add.d X, X, INCX + ld.d t4, X, 0 * SIZE + add.d X, X, INCX + xvinsgr2vr.d VX1, t1, 0 + xvinsgr2vr.d VX1, t2, 1 + xvinsgr2vr.d VX1, t3, 2 + xvinsgr2vr.d VX1, t4, 3 + xvadd.d VI2, VI1, VINC4 + xvfmina.d VM1, VX0, VX1 + xvfcmp.ceq.d VT0, VX0, VM1 + xvbitsel.v VI2, VI2, VI1, VT0 + xvfmina.d VM1, VM0, VM1 + xvfcmp.ceq.d VT0, VM0, VM1 + addi.d I, I, -1 + xvbitsel.v VM0, VM1, VM0, VT0 + xvbitsel.v VI0, VI2, VI0, VT0 + blt $r0, I, .L24 + .align 3 + +.L25: + xvpickve.d VI1, VI0, 0 + xvpickve.d VI2, VI0, 1 + xvpickve.d VI3, VI0, 2 + xvpickve.d VI4, VI0, 3 + xvpickve.d x1, VM0, 0 + xvpickve.d x2, VM0, 1 + xvpickve.d x3, VM0, 2 + xvpickve.d x4, VM0, 3 + xvfmina.d VM1, x1, x2 + xvfcmp.ceq.d VT0, x1, VM1 + xvbitsel.v VINC4, VI2, VI1, VT0 + xvfmina.d VM0, x4, x3 + xvfcmp.ceq.d VT0, x3, VM0 + xvbitsel.v VINC8, VI4, VI3, VT0 + xvfmina.d VM0, VM0, VM1 + xvfcmp.ceq.d VT0, VM0, VM1 + xvbitsel.v VI0, VINC8, VINC4, VT0 + li.d TEMP, 1 //处理尾数相等时取最小序号 + movgr2fr.d $f17, TEMP + ffint.d.l $f17, $f17 + xvfcmp.ceq.d VT0, VM0, x1 + fcmp.ceq.d $fcc0, $f23, $f17 + bceqz $fcc0, .L26 + xvfcmp.clt.d VT0, VI1, VI0 + xvbitsel.v VI0, VI0, VI1, VT0 + .align 3 + +.L26: + xvfcmp.ceq.d VT0, VM0, x2 + fcmp.ceq.d $fcc0, $f23, $f17 + bceqz $fcc0, .L27 + xvfcmp.clt.d VT0, VI2, VI0 + xvbitsel.v VI0, VI0, VI2, VT0 + .align 3 + +.L27: + xvfcmp.ceq.d VT0, VM0, x3 + fcmp.ceq.d $fcc0, $f23, $f17 + bceqz $fcc0, .L28 + xvfcmp.clt.d VT0, VI3, VI0 + xvbitsel.v VI0, VI0, VI3, VT0 + .align 3 + +.L28: + xvfcmp.ceq.d VT0, VM0, x4 + fcmp.ceq.d $fcc0, $f23, $f17 + bceqz $fcc0, .L29 + xvfcmp.clt.d VT0, VI4, VI0 + xvbitsel.v VI0, VI0, VI4, VT0 + .align 3 + +.L29: + movfr2gr.d i0, $f20 + .align 3 + +.L21: // N<8 + andi I, N, 7 + bge $r0, I, .L999 + srai.d i1, N, 3 + slli.d i1, i1, 3 + addi.d i1, i1, 1 //current index + movgr2fr.d $f21, i1 + movgr2fr.d $f20, i0 + .align 3 + +.L22: + fld.d $f9, X, 0 + addi.d I, I, -1 + xvfmina.d VM1, x1, VM0 + xvfcmp.ceq.d VT0, VM0, VM1 + add.d X, X, INCX + xvbitsel.v VM0, VM1, VM0, VT0 + xvbitsel.v VI0, VI1, VI0, VT0 + addi.d i1, i1, 1 + movgr2fr.d $f21, i1 + blt $r0, I, .L22 + movfr2gr.d i0, $f20 + .align 3 + +.L999: + move $r4, $r17 + jirl $r0, $r1, 0x0 + .align 3 + + EPILOGUE diff --git a/kernel/loongarch64/idamin_lsx.S b/kernel/loongarch64/idamin_lsx.S new file mode 100644 index 000000000..9eb9d883f --- /dev/null +++ b/kernel/loongarch64/idamin_lsx.S @@ -0,0 +1,228 @@ +#define ASSEMBLER + +#include "common.h" + +#define N $r4 +#define X $r5 +#define INCX $r6 +#define I $r12 +#define t1 $r13 +#define t2 $r15 +#define t3 $r18 +#define t4 $r16 +#define i0 $r17 +#define i1 $r14 +#define TEMP $r19 +#define x1 $vr9 +#define x2 $vr10 +#define x3 $vr11 +#define x4 $vr12 +#define VX0 $vr13 +#define VX1 $vr14 +#define VM0 $vr15 +#define VM1 $vr16 +#define VINC2 $vr17 +#define VINC4 $vr18 +#define VI0 $vr20 +#define VI1 $vr21 +#define VI2 $vr22 +#define VI3 $vr8 +#define VI4 $vr19 +#define VT0 $vr23 + + PROLOGUE + li.d i0, 0 + bge $r0, N, .L999 + bge $r0, INCX, .L999 + li.d TEMP, 1 + slli.d TEMP, TEMP, BASE_SHIFT + slli.d INCX, INCX, BASE_SHIFT + bne INCX, TEMP, .L20 + vld VM0, X, 0 + addi.d i0, i0, 1 + srai.d I, N, 3 + bge $r0, I, .L21 + slli.d i0, i0, 1 //2 + vreplgr2vr.d VINC2, i0 + slli.d i0, i0, 1 //4 + vreplgr2vr.d VINC4, i0 + addi.d i0, i0, -7 + vinsgr2vr.d VI1, i0, 0 //initialize the index value for vectorization + addi.d i0, i0, 1 + vinsgr2vr.d VI1, i0, 1 + addi.d i0, i0, 3 + vinsgr2vr.d VI0, i0, 0 //1 + addi.d i0, i0, 1 + vinsgr2vr.d VI0, i0, 1 //2 + .align 3 + +.L10: + vld VX0, X, 0 * SIZE + vadd.d VI1, VI1, VINC4 + vld VX1, X, 2 * SIZE + vadd.d VI2, VI1, VINC2 + vfmina.d x1, VX0, VX1 + vfcmp.ceq.d VT0, VX0, x1 + vbitsel.v x2, VI2, VI1, VT0 + vld VX0, X, 4 * SIZE + vadd.d VI1, VI2, VINC2 + vld VX1, X, 6 * SIZE + vadd.d VI2, VI1, VINC2 + vfmina.d x3, VX0, VX1 + vfcmp.ceq.d VT0, VX0, x3 + vbitsel.v x4, VI2, VI1, VT0 + vfmina.d x3, x1, x3 + vfcmp.ceq.d VT0, x1, x3 + addi.d I, I, -1 + vbitsel.v x2, x4, x2, VT0 + vfmina.d VM1, VM0, x3 + vfcmp.ceq.d VT0, VM0, VM1 + addi.d X, X, 8 * SIZE + vbitsel.v VM0, VM1, VM0, VT0 + vbitsel.v VI0, x2, VI0, VT0 + blt $r0, I, .L10 + .align 3 + +.L15: + vreplvei.d VI1, VI0, 0 + vreplvei.d VI2, VI0, 1 + vreplvei.d x1, VM0, 0 + vreplvei.d x2, VM0, 1 + li.d TEMP, 1 //处理尾数相等时取最小序号 + movgr2fr.d $f17, TEMP + ffint.d.l $f17, $f17 + vfcmp.ceq.d VT0, x2, x1 + fcmp.ceq.d $fcc0, $f23, $f17 + bceqz $fcc0, .L26 + vfcmp.clt.d VT0, VI1, VI0 + vbitsel.v VI0, VI0, VI1, VT0 + b .L27 + .align 3 + +.L20: // INCX!=1 + move TEMP, X + addi.d i0, i0, 1 + ld.d t1, TEMP, 0 * SIZE + add.d TEMP, TEMP, INCX + vinsgr2vr.d VM0, t1, 0 + srai.d I, N, 3 + bge $r0, I, .L21 + ld.d t2, TEMP, 0 * SIZE + add.d TEMP, TEMP, INCX + vinsgr2vr.d VM0, t2, 1 + slli.d i0, i0, 1 //2 + vreplgr2vr.d VINC2, i0 + slli.d i0, i0, 1 //4 + vreplgr2vr.d VINC4, i0 + addi.d i0, i0, -7 + vinsgr2vr.d VI1, i0, 0 //initialize the index value for vectorization + addi.d i0, i0, 1 + vinsgr2vr.d VI1, i0, 1 + addi.d i0, i0, 3 + vinsgr2vr.d VI0, i0, 0 //1 + addi.d i0, i0, 1 + vinsgr2vr.d VI0, i0, 1 //2 + .align 3 + +.L24: + ld.d t1, X, 0 * SIZE + add.d X, X, INCX + ld.d t2, X, 0 * SIZE + add.d X, X, INCX + vinsgr2vr.d VX0, t1, 0 + vinsgr2vr.d VX0, t2, 1 + vadd.d VI1, VI1, VINC4 + ld.d t1, X, 0 * SIZE + add.d X, X, INCX + ld.d t2, X, 0 * SIZE + add.d X, X, INCX + vinsgr2vr.d VX1, t1, 0 + vinsgr2vr.d VX1, t2, 1 + vadd.d VI2, VI1, VINC2 + vfmina.d x1, VX0, VX1 + vfcmp.ceq.d VT0, VX0, x1 + vbitsel.v x2, VI2, VI1, VT0 + ld.d t1, X, 0 * SIZE + add.d X, X, INCX + ld.d t2, X, 0 * SIZE + add.d X, X, INCX + vinsgr2vr.d VX0, t1, 0 + vinsgr2vr.d VX0, t2, 1 + vadd.d VI1, VI2, VINC2 + ld.d t1, X, 0 * SIZE + add.d X, X, INCX + ld.d t2, X, 0 * SIZE + add.d X, X, INCX + vinsgr2vr.d VX1, t1, 0 + vinsgr2vr.d VX1, t2, 1 + vadd.d VI2, VI1, VINC2 + vfmina.d x3, VX0, VX1 + vfcmp.ceq.d VT0, VX0, x3 + vbitsel.v x4, VI2, VI1, VT0 + vfmina.d x3, x1, x3 + vfcmp.ceq.d VT0, x1, x3 + addi.d I, I, -1 + vbitsel.v x2, x4, x2, VT0 + vfmina.d VM1, VM0, x3 + vbitsel.v VM0, VM1, VM0, VT0 + vfcmp.ceq.d VT0, VM0, VM1 + vbitsel.v VI0, x2, VI0, VT0 + blt $r0, I, .L24 + .align 3 + +.L25: + vreplvei.d VI1, VI0, 0 + vreplvei.d VI2, VI0, 1 + vreplvei.d x1, VM0, 0 + vreplvei.d x2, VM0, 1 + li.d TEMP, 1 //处理尾数相等时取最小序号 + movgr2fr.d $f17, TEMP + ffint.d.l $f17, $f17 + vfcmp.ceq.d VT0, x2, x1 + fcmp.ceq.d $fcc0, $f23, $f17 + bceqz $fcc0, .L26 + vfcmp.clt.d VT0, VI1, VI0 + vbitsel.v VI0, VI0, VI1, VT0 + b .L27 + .align 3 + +.L26: + vfmina.d VM0, x1, x2 + vfcmp.ceq.d VT0, x1, VM0 + vbitsel.v VI0, VI2, VI1, VT0 + .align 3 + +.L27: + movfr2gr.d i0, $f20 + .align 3 + +.L21: //N<8 + andi I, N, 7 + bge $r0, I, .L999 + srai.d i1, N, 3 + slli.d i1, i1, 3 + addi.d i1, i1, 1 //current index + movgr2fr.d $f21, i1 + movgr2fr.d $f20, i0 + .align 3 + +.L22: + fld.d $f9, X, 0 + addi.d I, I, -1 + vfmina.d VM1, x1, VM0 + vfcmp.ceq.d VT0, VM0, VM1 + add.d X, X, INCX + vbitsel.v VM0, VM1, VM0, VT0 + vbitsel.v VI0, VI1, VI0, VT0 + addi.d i1, i1, 1 + movgr2fr.d $f21, i1 + blt $r0, I, .L22 + movfr2gr.d i0, $f20 + .align 3 + +.L999: + move $r4, $r17 + jirl $r0, $r1, 0x0 + .align 3 + + EPILOGUE diff --git a/kernel/loongarch64/isamin_lasx.S b/kernel/loongarch64/isamin_lasx.S new file mode 100644 index 000000000..cbdf32530 --- /dev/null +++ b/kernel/loongarch64/isamin_lasx.S @@ -0,0 +1,378 @@ +#define ASSEMBLER + +#include "common.h" + +#define N $r4 +#define X $r5 +#define INCX $r6 +#define I $r12 +#define t1 $r13 +#define t2 $r15 +#define t3 $r18 +#define t4 $r16 +#define i0 $r17 +#define i1 $r14 +#define TEMP $r19 +#define x1 $xr9 +#define x2 $xr10 +#define x3 $xr11 +#define x4 $xr12 +#define VX0 $xr13 +#define VX1 $xr14 +#define VM0 $xr15 +#define VM1 $xr16 +#define VINC4 $xr17 +#define VINC8 $xr18 +#define VI0 $xr20 +#define VI1 $xr21 +#define VI2 $xr22 +#define VI3 $xr8 +#define VI4 $xr19 +#define VT0 $xr23 + + PROLOGUE + li.d i0, 0 + bge $r0, N, .L999 + bge $r0, INCX, .L999 + li.d TEMP, 1 + slli.d TEMP, TEMP, BASE_SHIFT + slli.d INCX, INCX, BASE_SHIFT + bne INCX, TEMP, .L20 + xvld VM0, X, 0 + addi.w i0, i0, 1 + srai.d I, N, 3 + bge $r0, I, .L21 + slli.w i0, i0, 3 //8 + xvreplgr2vr.w VINC8, i0 + addi.w i0, i0, -15 + xvinsgr2vr.w VI1, i0, 0 //initialize the index value for vectorization + addi.w i0, i0, 1 + xvinsgr2vr.w VI1, i0, 1 + addi.w i0, i0, 1 + xvinsgr2vr.w VI1, i0, 2 + addi.w i0, i0, 1 + xvinsgr2vr.w VI1, i0, 3 + addi.w i0, i0, 1 + xvinsgr2vr.w VI1, i0, 4 + addi.w i0, i0, 1 + xvinsgr2vr.w VI1, i0, 5 + addi.w i0, i0, 1 + xvinsgr2vr.w VI1, i0, 6 + addi.w i0, i0, 1 + xvinsgr2vr.w VI1, i0, 7 + addi.w i0, i0, 1 + xvinsgr2vr.w VI0, i0, 0 //1 + addi.w i0, i0, 1 + xvinsgr2vr.w VI0, i0, 1 //2 + addi.w i0, i0, 1 + xvinsgr2vr.w VI0, i0, 2 //3 + addi.w i0, i0, 1 + xvinsgr2vr.w VI0, i0, 3 //4 + addi.w i0, i0, 1 + xvinsgr2vr.w VI0, i0, 4 //5 + addi.w i0, i0, 1 + xvinsgr2vr.w VI0, i0, 5 //6 + addi.w i0, i0, 1 + xvinsgr2vr.w VI0, i0, 6 //7 + addi.w i0, i0, 1 + xvinsgr2vr.w VI0, i0, 7 //8 + .align 3 + +.L10: + xvld VX0, X, 0 * SIZE + addi.d I, I, -1 + xvadd.w VI1, VI1, VINC8 + xvfmina.s VM1, VX0, VM0 + xvfcmp.ceq.s VT0, VM0, VM1 + addi.d X, X, 8 * SIZE + xvbitsel.v VM0, VM1, VM0, VT0 + xvbitsel.v VI0, VI1, VI0, VT0 + blt $r0, I, .L10 + .align 3 + +.L15: + xvxor.v VX0, VX0, VX0 + xvor.v VX0, VI0, VX0 + xvxor.v VX1, VX1, VX1 + xvor.v VX1, VM0, VX1 + xvpickve.w VI1, VI0, 0 + xvpickve.w VI2, VI0, 1 + xvpickve.w VI3, VI0, 2 + xvpickve.w VI4, VI0, 3 + xvpickve.w x1, VM0, 0 + xvpickve.w x2, VM0, 1 + xvpickve.w x3, VM0, 2 + xvpickve.w x4, VM0, 3 + xvfmina.s VM1, x1, x2 + xvfcmp.ceq.s VT0, x1, VM1 + xvbitsel.v VINC4, VI2, VI1, VT0 + xvfmina.s VM0, x3, x4 + xvfcmp.ceq.s VT0, x3, VM0 + xvbitsel.v VINC8, VI4, VI3, VT0 + xvfmina.s VM0, VM0, VM1 + xvfcmp.ceq.s VT0, VM0, VM1 + xvbitsel.v VI0, VINC8, VINC4, VT0 + li.d TEMP, 1 //处理尾数相等时取最小序号 + movgr2fr.w $f17, TEMP + ffint.s.w $f17, $f17 + xvfcmp.ceq.s VT0, VM0, x1 + fcmp.ceq.s $fcc0, $f23, $f17 + bceqz $fcc0, .L26 + xvfcmp.clt.s VT0, VI1, VI0 + xvbitsel.v VI0, VI0, VI1, VT0 + b .L26 + .align 3 + +.L20: // INCX!=1 + move TEMP, X + addi.w i0, i0, 1 + ld.w t1, TEMP, 0 * SIZE + add.d TEMP, TEMP, INCX + xvinsgr2vr.w VM0, t1, 0 + srai.d I, N, 3 + bge $r0, I, .L21 + ld.w t2, TEMP, 0 * SIZE + add.d TEMP, TEMP, INCX + ld.w t3, TEMP, 0 * SIZE + add.d TEMP, TEMP, INCX + ld.w t4, TEMP, 0 * SIZE + add.d TEMP, TEMP, INCX + xvinsgr2vr.w VM0, t2, 1 + xvinsgr2vr.w VM0, t3, 2 + xvinsgr2vr.w VM0, t4, 3 + ld.w t1, TEMP, 0 * SIZE + add.d TEMP, TEMP, INCX + ld.w t2, TEMP, 0 * SIZE + add.d TEMP, TEMP, INCX + ld.w t3, TEMP, 0 * SIZE + add.d TEMP, TEMP, INCX + ld.w t4, TEMP, 0 * SIZE + add.d TEMP, TEMP, INCX + xvinsgr2vr.w VM0, t1, 4 + xvinsgr2vr.w VM0, t2, 5 + xvinsgr2vr.w VM0, t3, 6 + xvinsgr2vr.w VM0, t4, 7 + slli.w i0, i0, 3 //8 + xvreplgr2vr.w VINC8, i0 + addi.w i0, i0, -15 + xvinsgr2vr.w VI1, i0, 0 //initialize the index value for vectorization + addi.w i0, i0, 1 + xvinsgr2vr.w VI1, i0, 1 + addi.w i0, i0, 1 + xvinsgr2vr.w VI1, i0, 2 + addi.w i0, i0, 1 + xvinsgr2vr.w VI1, i0, 3 + addi.w i0, i0, 1 + xvinsgr2vr.w VI1, i0, 4 + addi.w i0, i0, 1 + xvinsgr2vr.w VI1, i0, 5 + addi.w i0, i0, 1 + xvinsgr2vr.w VI1, i0, 6 + addi.w i0, i0, 1 + xvinsgr2vr.w VI1, i0, 7 + addi.w i0, i0, 1 + xvinsgr2vr.w VI0, i0, 0 //1 + addi.w i0, i0, 1 + xvinsgr2vr.w VI0, i0, 1 //2 + addi.w i0, i0, 1 + xvinsgr2vr.w VI0, i0, 2 //3 + addi.w i0, i0, 1 + xvinsgr2vr.w VI0, i0, 3 //4 + addi.w i0, i0, 1 + xvinsgr2vr.w VI0, i0, 4 //5 + addi.w i0, i0, 1 + xvinsgr2vr.w VI0, i0, 5 //6 + addi.w i0, i0, 1 + xvinsgr2vr.w VI0, i0, 6 //7 + addi.w i0, i0, 1 + xvinsgr2vr.w VI0, i0, 7 //8 + .align 3 + +.L24: + ld.w t1, X, 0 * SIZE + add.d X, X, INCX + ld.w t2, X, 0 * SIZE + add.d X, X, INCX + ld.w t3, X, 0 * SIZE + add.d X, X, INCX + ld.w t4, X, 0 * SIZE + add.d X, X, INCX + xvinsgr2vr.w VX0, t1, 0 + xvinsgr2vr.w VX0, t2, 1 + xvinsgr2vr.w VX0, t3, 2 + xvinsgr2vr.w VX0, t4, 3 + ld.w t1, X, 0 * SIZE + add.d X, X, INCX + ld.w t2, X, 0 * SIZE + add.d X, X, INCX + ld.w t3, X, 0 * SIZE + add.d X, X, INCX + ld.w t4, X, 0 * SIZE + add.d X, X, INCX + xvinsgr2vr.w VX0, t1, 4 + xvinsgr2vr.w VX0, t2, 5 + xvinsgr2vr.w VX0, t3, 6 + xvinsgr2vr.w VX0, t4, 7 + xvadd.w VI1, VI1, VINC8 + xvfmina.s VM1, VX0, VM0 + xvfcmp.ceq.s VT0, VM1, VM0 + addi.d I, I, -1 + xvbitsel.v VM0, VM1, VM0, VT0 + xvbitsel.v VI0, VI1, VI0, VT0 + blt $r0, I, .L24 + .align 3 + +.L25: + xvxor.v VX0, VX0, VX0 + xvor.v VX0, VI0, VX0 + xvxor.v VX1, VX1, VX1 + xvor.v VX1, VM0, VX1 + xvpickve.w VI1, VI0, 0 + xvpickve.w VI2, VI0, 1 + xvpickve.w VI3, VI0, 2 + xvpickve.w VI4, VI0, 3 + xvpickve.w x1, VM0, 0 + xvpickve.w x2, VM0, 1 + xvpickve.w x3, VM0, 2 + xvpickve.w x4, VM0, 3 + xvfmina.s VM1, x1, x2 + xvfcmp.ceq.s VT0, x1, VM1 + xvbitsel.v VINC4, VI2, VI1, VT0 + xvfmina.s VM0, x3, x4 + xvfcmp.ceq.s VT0, x3, VM0 + xvbitsel.v VINC8, VI3, VI4, VT0 + xvfmina.s VM0, VM0, VM1 + xvfcmp.ceq.s VT0, VM0, VM1 + xvbitsel.v VM0, VM0, VM1, VT0 + xvbitsel.v VI0, VINC8, VINC4, VT0 + li.d TEMP, 1 //处理尾数相等时取最小序号 + movgr2fr.w $f17, TEMP + ffint.s.w $f17, $f17 + xvfcmp.ceq.s VT0, VM0, x1 + fcmp.ceq.s $fcc0, $f23, $f17 + bceqz $fcc0, .L26 + xvfcmp.clt.s VT0, VI1, VI0 + xvbitsel.v VI0, VI0, VI1, VT0 + .align 3 + +.L26: + xvfcmp.ceq.s VT0, VM0, x2 + fcmp.ceq.s $fcc0, $f23, $f17 + bceqz $fcc0, .L27 + xvfcmp.clt.s VT0, VI2, VI0 + xvbitsel.v VI0, VI0, VI2, VT0 + .align 3 + +.L27: + xvfcmp.ceq.s VT0, VM0, x3 + fcmp.ceq.s $fcc0, $f23, $f17 + bceqz $fcc0, .L28 + xvfcmp.clt.s VT0, VI3, VI0 + xvbitsel.v VI0, VI0, VI3, VT0 + .align 3 + +.L28: + xvfcmp.ceq.s VT0, VM0, x4 + fcmp.ceq.s $fcc0, $f23, $f17 + bceqz $fcc0, .L29 + xvfcmp.clt.s VT0, VI4, VI0 + xvbitsel.v VI0, VI0, VI4, VT0 + .align 3 + +.L29: + fmov.s $f16, $f20 + .align 3 + +.L252: + xvxor.v VI0, VI0, VI0 + xvor.v VI0, VI0, VX0 + fmov.s $f13, $f15 + xvxor.v VM0, VM0, VM0 + xvor.v VM0, VM0, VX1 + xvpickve.w VI1, VI0, 4 + xvpickve.w VI2, VI0, 5 + xvpickve.w VI3, VI0, 6 + xvpickve.w VI4, VI0, 7 + xvpickve.w x1, VM0, 4 + xvpickve.w x2, VM0, 5 + xvpickve.w x3, VM0, 6 + xvpickve.w x4, VM0, 7 + xvfmina.s VM1, x1, x2 + xvfcmp.ceq.s VT0, x1, VM1 + xvbitsel.v VINC4, VI2, VI1, VT0 + xvfmina.s VM0, x3, x4 + xvfcmp.ceq.s VT0, x3, VM0 + xvbitsel.v VINC8, VI4, VI3, VT0 + xvfmina.s VM0, VM0, VM1 + xvfcmp.ceq.s VT0, VM0, VM1 + xvbitsel.v VI0, VINC8, VINC4, VT0 + li.d TEMP, 1 //处理尾数相等时取最小序号 + movgr2fr.w $f17, TEMP + ffint.s.w $f17, $f17 + xvfcmp.ceq.s VT0, VM0, x1 + fcmp.ceq.s $fcc0, $f23, $f17 + bceqz $fcc0, .L262 + xvfcmp.clt.s VT0, VI1, VI0 + xvbitsel.v VI0, VI0, VI1, VT0 + .align 3 + +.L262: + xvfcmp.ceq.s VT0, VM0, x2 + fcmp.ceq.s $fcc0, $f23, $f17 + bceqz $fcc0, .L272 + xvfcmp.clt.s VT0, VI2, VI0 + xvbitsel.v VI0, VI0, VI2, VT0 + .align 3 + +.L272: + xvfcmp.ceq.s VT0, VM0, x3 + fcmp.ceq.s $fcc0, $f23, $f17 + bceqz $fcc0, .L282 + xvfcmp.clt.s VT0, VI3, VI0 + xvbitsel.v VI0, VI0, VI3, VT0 + .align 3 + +.L282: + xvfcmp.ceq.s VT0, VM0, x4 + fcmp.ceq.s $fcc0, $f23, $f17 + bceqz $fcc0, .L292 + xvfcmp.clt.s VT0, VI4, VI0 + xvbitsel.v VI0, VI0, VI4, VT0 + .align 3 + +.L292: + xvfmina.s VM0, VX0, VM0 + xvfcmp.ceq.s VT0, VM0, VX0 + xvbitsel.v VI0, VI0, VI1, VT0 + movfr2gr.s i0, $f20 + +.L21: //N<8 + andi I, N, 7 + bge $r0, I, .L999 + srai.d i1, N, 3 + slli.d i1, i1, 3 + addi.d i1, i1, 1 //current index + movgr2fr.d $f21, i1 + movgr2fr.d $f20, i0 + .align 3 + +.L22: + fld.s $f9, X, 0 + addi.d I, I, -1 + xvfmina.s VM1, x1, VM0 + xvfcmp.ceq.s VT0, VM0, VM1 + add.d X, X, INCX + xvbitsel.v VM0, VM1, VM0, VT0 + xvbitsel.v VI0, VI1, VI0, VT0 + addi.d i1, i1, 1 + movgr2fr.d $f21, i1 + blt $r0, I, .L22 + movfr2gr.s i0, $f20 + .align 3 + +.L999: + move $r4, $r17 + jirl $r0, $r1, 0x0 + .align 3 + + EPILOGUE \ No newline at end of file diff --git a/kernel/loongarch64/isamin_lsx.S b/kernel/loongarch64/isamin_lsx.S new file mode 100644 index 000000000..598888660 --- /dev/null +++ b/kernel/loongarch64/isamin_lsx.S @@ -0,0 +1,275 @@ +#define ASSEMBLER + +#include "common.h" + +#define N $r4 +#define X $r5 +#define INCX $r6 +#define I $r12 +#define t1 $r13 +#define t2 $r15 +#define t3 $r18 +#define t4 $r16 +#define i0 $r17 +#define i1 $r14 +#define TEMP $r19 +#define x1 $vr9 +#define x2 $vr10 +#define x3 $vr11 +#define x4 $vr12 +#define VX0 $vr13 +#define VX1 $vr14 +#define VM0 $vr15 +#define VM1 $vr16 +#define VINC4 $vr17 +#define VINC8 $vr18 +#define VI0 $vr20 +#define VI1 $vr21 +#define VI2 $vr22 +#define VI3 $vr8 +#define VI4 $vr19 +#define VT0 $vr23 + + PROLOGUE + li.d i0, 0 + bge $r0, N, .L999 + bge $r0, INCX, .L999 + li.d TEMP, 1 + slli.d TEMP, TEMP, BASE_SHIFT + slli.d INCX, INCX, BASE_SHIFT + bne INCX, TEMP, .L20 + vld VM0, X, 0 + addi.w i0, i0, 1 + srai.d I, N, 3 + bge $r0, I, .L21 + slli.w i0, i0, 2 //4 + vreplgr2vr.w VINC4, i0 + slli.w i0, i0, 1 //8 + vreplgr2vr.w VINC8, i0 + addi.w i0, i0, -15 + vinsgr2vr.w VI1, i0, 0 //initialize the index value for vectorization + addi.w i0, i0, 1 + vinsgr2vr.w VI1, i0, 1 + addi.w i0, i0, 1 + vinsgr2vr.w VI1, i0, 2 + addi.w i0, i0, 1 + vinsgr2vr.w VI1, i0, 3 + addi.w i0, i0, 5 + vinsgr2vr.w VI0, i0, 0 //1 + addi.w i0, i0, 1 + vinsgr2vr.w VI0, i0, 1 //2 + addi.w i0, i0, 1 + vinsgr2vr.w VI0, i0, 2 //3 + addi.w i0, i0, 1 + vinsgr2vr.w VI0, i0, 3 //4 + .align 3 + +.L10: + vld VX0, X, 0 * SIZE + vadd.w VI1, VI1, VINC8 + vld VX1, X, 4 * SIZE + vadd.w VI2, VI1, VINC4 + vfmina.s VM1, VX0, VX1 + vfcmp.ceq.s VT0, VX0, VM1 + addi.d I, I, -1 + vbitsel.v VI2, VI2, VI1, VT0 + vfmina.s VM1, VM0, VM1 + vfcmp.ceq.s VT0, VM0, VM1 + addi.d X, X, 8 * SIZE + vbitsel.v VM0, VM1, VM0, VT0 + vbitsel.v VI0, VI2, VI0, VT0 + blt $r0, I, .L10 + .align 3 + +.L15: + vreplvei.w VI1, VI0, 0 + vreplvei.w VI2, VI0, 1 + vreplvei.w VI3, VI0, 2 + vreplvei.w VI4, VI0, 3 + vreplvei.w x1, VM0, 0 + vreplvei.w x2, VM0, 1 + vreplvei.w x3, VM0, 2 + vreplvei.w x4, VM0, 3 + vfmina.s VM1, x1, x2 + vfcmp.ceq.s VT0, VM1, x1 + vbitsel.v VINC4, VI2, VI1, VT0 + vfmina.s VM0, x3, x4 + vfcmp.ceq.s VT0, x3, VM0 + vbitsel.v VINC8, VI4, VI3, VT0 + vfmina.s VM0, VM0, VM1 + vfcmp.ceq.s VT0, VM0, VM1 + vbitsel.v VI0, VINC8, VINC4, VT0 + li.d TEMP, 1 //处理尾数相等时取最小序号 + movgr2fr.w $f17, TEMP + ffint.s.w $f17, $f17 + vfcmp.ceq.s VT0, VM0, x1 + fcmp.ceq.s $fcc0, $f23, $f17 + bceqz $fcc0, .L26 + vfcmp.clt.s VT0, VI1, VI0 + vbitsel.v VI0, VI0, VI1, VT0 + b .L26 + .align 3 + +.L20: // INCX!=1 + move TEMP, X + addi.w i0, i0, 1 + ld.w t1, TEMP, 0 * SIZE + add.d TEMP, TEMP, INCX + vinsgr2vr.w VM0, t1, 0 + srai.d I, N, 3 + bge $r0, I, .L21 + ld.w t2, TEMP, 0 * SIZE + add.d TEMP, TEMP, INCX + ld.w t3, TEMP, 0 * SIZE + add.d TEMP, TEMP, INCX + ld.w t4, TEMP, 0 * SIZE + add.d TEMP, TEMP, INCX + vinsgr2vr.w VM0, t2, 1 + vinsgr2vr.w VM0, t3, 2 + vinsgr2vr.w VM0, t4, 3 + slli.w i0, i0, 2 //4 + vreplgr2vr.w VINC4, i0 + slli.w i0, i0, 1 //8 + vreplgr2vr.w VINC8, i0 + addi.w i0, i0, -15 + vinsgr2vr.w VI1, i0, 0 //initialize the index value for vectorization + addi.w i0, i0, 1 + vinsgr2vr.w VI1, i0, 1 + addi.w i0, i0, 1 + vinsgr2vr.w VI1, i0, 2 + addi.w i0, i0, 1 + vinsgr2vr.w VI1, i0, 3 + addi.w i0, i0, 5 + vinsgr2vr.w VI0, i0, 0 //1 + addi.w i0, i0, 1 + vinsgr2vr.w VI0, i0, 1 //2 + addi.w i0, i0, 1 + vinsgr2vr.w VI0, i0, 2 //3 + addi.w i0, i0, 1 + vinsgr2vr.w VI0, i0, 3 //4 + .align 3 + +.L24: + ld.w t1, X, 0 * SIZE + add.d X, X, INCX + ld.w t2, X, 0 * SIZE + add.d X, X, INCX + ld.w t3, X, 0 * SIZE + add.d X, X, INCX + ld.w t4, X, 0 * SIZE + add.d X, X, INCX + vinsgr2vr.w VX0, t1, 0 + vinsgr2vr.w VX0, t2, 1 + vinsgr2vr.w VX0, t3, 2 + vinsgr2vr.w VX0, t4, 3 + vadd.w VI1, VI1, VINC8 + ld.w t1, X, 0 * SIZE + add.d X, X, INCX + ld.w t2, X, 0 * SIZE + add.d X, X, INCX + ld.w t3, X, 0 * SIZE + add.d X, X, INCX + ld.w t4, X, 0 * SIZE + add.d X, X, INCX + vinsgr2vr.w VX1, t1, 0 + vinsgr2vr.w VX1, t2, 1 + vinsgr2vr.w VX1, t3, 2 + vinsgr2vr.w VX1, t4, 3 + vadd.w VI2, VI1, VINC4 + vfmina.s VM1, VX0, VX1 + vfcmp.ceq.s VT0, VX0, VM1 + vbitsel.v VI2, VI2, VI1, VT0 + vfmina.s VM1, VM0, VM1 + vfcmp.ceq.s VT0, VM0, VM1 + addi.d I, I, -1 + vbitsel.v VM0, VM1, VM0, VT0 + vbitsel.v VI0, VI2, VI0, VT0 + blt $r0, I, .L24 + .align 3 + +.L25: + vreplvei.w VI1, VI0, 0 + vreplvei.w VI2, VI0, 1 + vreplvei.w VI3, VI0, 2 + vreplvei.w VI4, VI0, 3 + vreplvei.w x1, VM0, 0 + vreplvei.w x2, VM0, 1 + vreplvei.w x3, VM0, 2 + vreplvei.w x4, VM0, 3 + vfmina.s VM1, x1, x2 + vfcmp.ceq.s VT0, VM1, x1 + vbitsel.v VINC4, VI2, VI1, VT0 + vfmina.s VM0, x3, x4 + vfcmp.ceq.s VT0, x3, VM0 + vbitsel.v VINC8, VI4, VI3, VT0 + vfmina.s VM0, VM0, VM1 + vfcmp.ceq.s VT0, VM0, VM1 + vbitsel.v VI0, VINC8, VINC4, VT0 + li.d TEMP, 1 //处理尾数相等时取最小序号 + movgr2fr.w $f17, TEMP + ffint.s.w $f17, $f17 + vfcmp.ceq.s VT0, VM0, x1 + fcmp.ceq.s $fcc0, $f23, $f17 + bceqz $fcc0, .L26 + vfcmp.clt.s VT0, VI1, VI0 + vbitsel.v VI0, VI0, VI1, VT0 + .align 3 + +.L26: + vfcmp.ceq.s VT0, VM0, x2 + fcmp.ceq.s $fcc0, $f23, $f17 + bceqz $fcc0, .L27 + vfcmp.clt.s VT0, VI2, VI0 + vbitsel.v VI0, VI0, VI2, VT0 + .align 3 + +.L27: + vfcmp.ceq.s VT0, VM0, x3 + fcmp.ceq.s $fcc0, $f23, $f17 + bceqz $fcc0, .L28 + vfcmp.clt.s VT0, VI3, VI0 + vbitsel.v VI0, VI0, VI3, VT0 + .align 3 + +.L28: + vfcmp.ceq.s VT0, VM0, x4 + fcmp.ceq.s $fcc0, $f23, $f17 + bceqz $fcc0, .L29 + vfcmp.clt.s VT0, VI4, VI0 + vbitsel.v VI0, VI0, VI4, VT0 + .align 3 + +.L29: + movfr2gr.s i0, $f20 + .align 3 + +.L21: //N<8 + andi I, N, 7 + bge $r0, I, .L999 + srai.d i1, N, 3 + slli.d i1, i1, 3 + addi.d i1, i1, 1 //current index + movgr2fr.d $f21, i1 + movgr2fr.d $f20, i0 + .align 3 + +.L22: + fld.s $f9, X, 0 + addi.d I, I, -1 + vfmina.s VM1, x1, VM0 + vfcmp.ceq.s VT0, VM0, VM1 + add.d X, X, INCX + vbitsel.v VM0, VM1, VM0, VT0 + vbitsel.v VI0, VI1, VI0, VT0 + addi.d i1, i1, 1 + movgr2fr.d $f21, i1 + blt $r0, I, .L22 + movfr2gr.s i0, $f20 + .align 3 + +.L999: + move $r4, $r17 + jirl $r0, $r1, 0x0 + .align 3 + + EPILOGUE \ No newline at end of file From 174c25766b6b43e36a9ace6da26fe21f3a7305a9 Mon Sep 17 00:00:00 2001 From: yancheng Date: Thu, 7 Dec 2023 12:15:46 +0800 Subject: [PATCH 52/60] loongarch64: Add optimizations for copy. --- kernel/loongarch64/KERNEL.LOONGSON2K1000 | 3 + kernel/loongarch64/KERNEL.LOONGSON3R5 | 3 + kernel/loongarch64/dcopy_lasx.S | 224 ++++++++++++++++++++++ kernel/loongarch64/dcopy_lsx.S | 232 +++++++++++++++++++++++ kernel/loongarch64/scopy_lasx.S | 216 +++++++++++++++++++++ kernel/loongarch64/scopy_lsx.S | 220 +++++++++++++++++++++ 6 files changed, 898 insertions(+) create mode 100644 kernel/loongarch64/dcopy_lasx.S create mode 100644 kernel/loongarch64/dcopy_lsx.S create mode 100644 kernel/loongarch64/scopy_lasx.S create mode 100644 kernel/loongarch64/scopy_lsx.S diff --git a/kernel/loongarch64/KERNEL.LOONGSON2K1000 b/kernel/loongarch64/KERNEL.LOONGSON2K1000 index bff52ce93..565bec0f2 100644 --- a/kernel/loongarch64/KERNEL.LOONGSON2K1000 +++ b/kernel/loongarch64/KERNEL.LOONGSON2K1000 @@ -31,4 +31,7 @@ IDAMAXKERNEL = idamax_lsx.S ISAMINKERNEL = isamin_lsx.S IDAMINKERNEL = idamin_lsx.S +SCOPYKERNEL = scopy_lsx.S +DCOPYKERNEL = dcopy_lsx.S + endif diff --git a/kernel/loongarch64/KERNEL.LOONGSON3R5 b/kernel/loongarch64/KERNEL.LOONGSON3R5 index a08598cc5..a2443720b 100644 --- a/kernel/loongarch64/KERNEL.LOONGSON3R5 +++ b/kernel/loongarch64/KERNEL.LOONGSON3R5 @@ -31,6 +31,9 @@ IDAMAXKERNEL = idamax_lasx.S ISAMINKERNEL = isamin_lasx.S IDAMINKERNEL = idamin_lasx.S +SCOPYKERNEL = scopy_lasx.S +DCOPYKERNEL = dcopy_lasx.S + DGEMMKERNEL = dgemm_kernel_16x4.S DGEMMINCOPY = dgemm_ncopy_16.S DGEMMITCOPY = dgemm_tcopy_16.S diff --git a/kernel/loongarch64/dcopy_lasx.S b/kernel/loongarch64/dcopy_lasx.S new file mode 100644 index 000000000..9d7da4a80 --- /dev/null +++ b/kernel/loongarch64/dcopy_lasx.S @@ -0,0 +1,224 @@ +#define ASSEMBLER + +#include "common.h" +#define N $r4 +#define X $r5 +#define INCX $r6 +#define Y $r7 +#define INCY $r8 +#define I $r17 +#define TEMP $r18 +#define t1 $r14 +#define t2 $r15 +#define t3 $r16 +#define t4 $r19 +#define a1 $f12 +#define a2 $f13 +#define a3 $f14 +#define a4 $f15 +#define VX0 $xr12 +#define VX1 $xr13 + + PROLOGUE + bge $r0, N, .L999 + li.d TEMP, 1 + slli.d TEMP, TEMP, BASE_SHIFT + slli.d INCX, INCX, BASE_SHIFT + slli.d INCY, INCY, BASE_SHIFT + srai.d I, N, 3 + bne INCX, TEMP, .L20 + bne INCY, TEMP, .L12 // INCX==1 and INCY!=1 + b .L11 // INCX==1 and INCY==1 +.L20: + bne INCY, TEMP, .L22 // INCX!=1 and INCY!=1 + b .L21 // INCX!=1 and INCY==1 + +.L11: + bge $r0, I, .L112 + .align 3 + +.L111: + xvld VX0, X, 0 * SIZE + xvld VX1, X, 4 * SIZE + xvst VX0, Y, 0 * SIZE + xvst VX1, Y, 4 * SIZE + addi.d X, X, 8 * SIZE + addi.d Y, Y, 8 * SIZE + addi.d I, I, -1 + blt $r0, I, .L111 + .align 3 + +.L112: + andi I, N, 7 + bge $r0, I, .L999 + .align 3 + +.L113: + fld.d $f12, X, 0 * SIZE + addi.d I, I, -1 + addi.d X, X, SIZE + fst.d $f12, Y, 0 * SIZE + addi.d Y, Y, SIZE + blt $r0, I, .L113 + b .L999 + .align 3 + +.L12: + bge $r0, I, .L122 + .align 3 + +.L121: + xvld VX0, X, 0 * SIZE + xvld VX1, X, 4 * SIZE + xvstelm.d VX0, Y, 0, 0 + add.d Y, Y, INCY + xvstelm.d VX0, Y, 0, 1 + add.d Y, Y, INCY + xvstelm.d VX0, Y, 0, 2 + add.d Y, Y, INCY + xvstelm.d VX0, Y, 0, 3 + add.d Y, Y, INCY + xvstelm.d VX1, Y, 0, 0 + add.d Y, Y, INCY + xvstelm.d VX1, Y, 0, 1 + add.d Y, Y, INCY + xvstelm.d VX1, Y, 0, 2 + add.d Y, Y, INCY + xvstelm.d VX1, Y, 0, 3 + add.d Y, Y, INCY + addi.d X, X, 8 * SIZE + addi.d I, I, -1 + blt $r0, I, .L121 + .align 3 + +.L122: + andi I, N, 7 + bge $r0, I, .L999 + .align 3 + +.L123: + fld.d $f12, X, 0 * SIZE + addi.d I, I, -1 + addi.d X, X, SIZE + fst.d $f12, Y, 0 * SIZE + add.d Y, Y, INCY + blt $r0, I, .L123 + b .L999 + .align 3 + +.L21: + bge $r0, I, .L212 + .align 3 + +.L211: + ld.d t1, X, 0 * SIZE + add.d X, X, INCX + ld.d t2, X, 0 * SIZE + add.d X, X, INCX + ld.d t3, X, 0 * SIZE + add.d X, X, INCX + ld.d t4, X, 0 * SIZE + add.d X, X, INCX + xvinsgr2vr.d VX0, t1, 0 + xvinsgr2vr.d VX0, t2, 1 + xvinsgr2vr.d VX0, t3, 2 + xvinsgr2vr.d VX0, t4, 3 + xvst VX0, Y, 0 * SIZE + ld.d t1, X, 0 * SIZE + add.d X, X, INCX + ld.d t2, X, 0 * SIZE + add.d X, X, INCX + ld.d t3, X, 0 * SIZE + add.d X, X, INCX + ld.d t4, X, 0 * SIZE + add.d X, X, INCX + xvinsgr2vr.d VX1, t1, 0 + xvinsgr2vr.d VX1, t2, 1 + xvinsgr2vr.d VX1, t3, 2 + xvinsgr2vr.d VX1, t4, 3 + xvst VX1, Y, 4 * SIZE + addi.d Y, Y, 8 * SIZE + addi.d I, I, -1 + blt $r0, I, .L211 + .align 3 + +.L212: + andi I, N, 7 + bge $r0, I, .L999 + .align 3 + +.L213: + fld.d $f12, X, 0 * SIZE + addi.d I, I, -1 + fst.d $f12, Y, 0 * SIZE + add.d X, X, INCX + addi.d Y, Y, SIZE + blt $r0, I, .L213 + b .L999 + .align 3 + +.L22: + bgez INCX, .L220 + .align 3 + +.L220: + bge $r0, I, .L223 + .align 3 + +.L222: + fld.d a1, X, 0 * SIZE + add.d X, X, INCX + fld.d a2, X, 0 * SIZE + add.d X, X, INCX + fld.d a3, X, 0 * SIZE + add.d X, X, INCX + fld.d a4, X, 0 * SIZE + add.d X, X, INCX + fst.d a1, Y, 0 * SIZE + add.d Y, Y, INCY + fst.d a2, Y, 0 * SIZE + add.d Y, Y, INCY + fst.d a3, X, 0 * SIZE + add.d Y, Y, INCY + fst.d a4, X, 0 * SIZE + add.d Y, Y, INCY + fld.d a1, X, 0 * SIZE + add.d X, X, INCX + fld.d a2, X, 0 * SIZE + add.d X, X, INCX + fld.d a3, X, 0 * SIZE + add.d X, X, INCX + fld.d a4, X, 0 * SIZE + add.d X, X, INCX + fst.d a1, Y, 0 * SIZE + add.d Y, Y, INCY + fst.d a2, Y, 0 * SIZE + add.d Y, Y, INCY + fst.d a3, X, 0 * SIZE + add.d Y, Y, INCY + fst.d a4, X, 0 * SIZE + add.d Y, Y, INCY + addi.d I, I, -1 + blt $r0, I, .L222 + .align 3 + +.L223: + andi I, N, 7 + bge $r0, I, .L999 + .align 3 + +.L224: + fld.d $f12, X, 0 * SIZE + addi.d I, I, -1 + fst.d $f12, Y, 0 * SIZE + add.d X, X, INCX + add.d Y, Y, INCY + blt $r0, I, .L224 + .align 3 + +.L999: + move $r4, $r12 + jirl $r0, $r1, 0x0 + .align 3 + + EPILOGUE diff --git a/kernel/loongarch64/dcopy_lsx.S b/kernel/loongarch64/dcopy_lsx.S new file mode 100644 index 000000000..161655bbd --- /dev/null +++ b/kernel/loongarch64/dcopy_lsx.S @@ -0,0 +1,232 @@ +#define ASSEMBLER + +#include "common.h" +#define N $r4 +#define X $r5 +#define INCX $r6 +#define Y $r7 +#define INCY $r8 +#define I $r17 +#define TEMP $r18 +#define t1 $r14 +#define t2 $r15 +#define t3 $r16 +#define t4 $r19 +#define a1 $f12 +#define a2 $f13 +#define a3 $f14 +#define a4 $f15 +#define VX0 $vr12 +#define VX1 $vr13 + + PROLOGUE + bge $r0, N, .L999 + li.d TEMP, 1 + slli.d TEMP, TEMP, BASE_SHIFT + slli.d INCX, INCX, BASE_SHIFT + slli.d INCY, INCY, BASE_SHIFT + srai.d I, N, 3 + bne INCX, TEMP, .L20 + bne INCY, TEMP, .L12 // INCX==1 and INCY!=1 + b .L11 // INCX==1 and INCY==1 +.L20: + bne INCY, TEMP, .L22 // INCX!=1 and INCY!=1 + b .L21 // INCX!=1 and INCY==1 + +.L11: + bge $r0, I, .L112 + .align 3 + +.L111: + vld VX0, X, 0 * SIZE + vld VX1, X, 2 * SIZE + vst VX0, Y, 0 * SIZE + vst VX1, Y, 2 * SIZE + vld VX0, X, 4 * SIZE + vld VX1, X, 6 * SIZE + addi.d I, I, -1 + vst VX0, Y, 4 * SIZE + vst VX1, Y, 6 * SIZE + addi.d X, X, 8 * SIZE + addi.d Y, Y, 8 * SIZE + blt $r0, I, .L111 + .align 3 + +.L112: + andi I, N, 7 + bge $r0, I, .L999 + .align 3 + +.L113: + fld.d $f12, X, 0 * SIZE + addi.d I, I, -1 + addi.d X, X, SIZE + fst.d $f12, Y, 0 * SIZE + addi.d Y, Y, SIZE + blt $r0, I, .L113 + b .L999 + .align 3 + +.L12: + bge $r0, I, .L122 + .align 3 + +.L121: + vld VX0, X, 0 * SIZE + vld VX1, X, 2 * SIZE + vstelm.d VX0, Y, 0, 0 + add.d Y, Y, INCY + vstelm.d VX0, Y, 0, 1 + add.d Y, Y, INCY + vstelm.d VX1, Y, 0, 0 + add.d Y, Y, INCY + vstelm.d VX1, Y, 0, 1 + add.d Y, Y, INCY + vld VX0, X, 4 * SIZE + vld VX1, X, 6 * SIZE + vstelm.d VX0, Y, 0, 0 + add.d Y, Y, INCY + vstelm.d VX0, Y, 0, 1 + add.d Y, Y, INCY + vstelm.d VX1, Y, 0, 0 + add.d Y, Y, INCY + vstelm.d VX1, Y, 0, 1 + add.d Y, Y, INCY + addi.d X, X, 8 * SIZE + addi.d I, I, -1 + blt $r0, I, .L121 + .align 3 + +.L122: + andi I, N, 7 + bge $r0, I, .L999 + .align 3 + +.L123: + fld.d $f12, X, 0 * SIZE + addi.d I, I, -1 + addi.d X, X, SIZE + fst.d $f12, Y, 0 * SIZE + add.d Y, Y, INCY + blt $r0, I, .L123 + b .L999 + .align 3 + +.L21: + bge $r0, I, .L212 + .align 3 + +.L211: + ld.d t1, X, 0 * SIZE + add.d X, X, INCX + ld.d t2, X, 0 * SIZE + add.d X, X, INCX + vinsgr2vr.d VX0, t1, 0 + vinsgr2vr.d VX0, t2, 1 + vst VX0, Y, 0 * SIZE + ld.d t3, X, 0 * SIZE + add.d X, X, INCX + ld.d t4, X, 0 * SIZE + add.d X, X, INCX + vinsgr2vr.d VX1, t3, 0 + vinsgr2vr.d VX1, t4, 1 + vst VX1, Y, 2 * SIZE + ld.d t1, X, 0 * SIZE + add.d X, X, INCX + ld.d t2, X, 0 * SIZE + add.d X, X, INCX + vinsgr2vr.d VX0, t1, 0 + vinsgr2vr.d VX0, t2, 1 + vst VX0, Y, 4 * SIZE + ld.d t3, X, 0 * SIZE + add.d X, X, INCX + ld.d t4, X, 0 * SIZE + add.d X, X, INCX + vinsgr2vr.d VX1, t3, 0 + vinsgr2vr.d VX1, t4, 1 + vst VX1, Y, 6 * SIZE + addi.d Y, Y, 8 * SIZE + addi.d I, I, -1 + blt $r0, I, .L211 + .align 3 + +.L212: + andi I, N, 7 + bge $r0, I, .L999 + .align 3 + +.L213: + fld.d $f12, X, 0 * SIZE + addi.d I, I, -1 + fst.d $f12, Y, 0 * SIZE + add.d X, X, INCX + addi.d Y, Y, SIZE + blt $r0, I, .L213 + b .L999 + .align 3 + +.L22: + bgez INCX, .L220 + .align 3 + +.L220: + bge $r0, I, .L223 + .align 3 + +.L222: + fld.d a1, X, 0 * SIZE + add.d X, X, INCX + fld.d a2, X, 0 * SIZE + add.d X, X, INCX + fld.d a3, X, 0 * SIZE + add.d X, X, INCX + fld.d a4, X, 0 * SIZE + add.d X, X, INCX + fst.d a1, Y, 0 * SIZE + add.d Y, Y, INCY + fst.d a2, Y, 0 * SIZE + add.d Y, Y, INCY + fst.d a3, X, 0 * SIZE + add.d Y, Y, INCY + fst.d a4, X, 0 * SIZE + add.d Y, Y, INCY + fld.d a1, X, 0 * SIZE + add.d X, X, INCX + fld.d a2, X, 0 * SIZE + add.d X, X, INCX + fld.d a3, X, 0 * SIZE + add.d X, X, INCX + fld.d a4, X, 0 * SIZE + add.d X, X, INCX + fst.d a1, Y, 0 * SIZE + add.d Y, Y, INCY + fst.d a2, Y, 0 * SIZE + add.d Y, Y, INCY + fst.d a3, X, 0 * SIZE + add.d Y, Y, INCY + fst.d a4, X, 0 * SIZE + add.d Y, Y, INCY + addi.d I, I, -1 + blt $r0, I, .L222 + .align 3 + +.L223: + andi I, N, 7 + bge $r0, I, .L999 + .align 3 + +.L224: + fld.d $f12, X, 0 * SIZE + addi.d I, I, -1 + fst.d $f12, Y, 0 * SIZE + add.d X, X, INCX + add.d Y, Y, INCY + blt $r0, I, .L224 + .align 3 + +.L999: + move $r4, $r12 + jirl $r0, $r1, 0x0 + .align 3 + + EPILOGUE diff --git a/kernel/loongarch64/scopy_lasx.S b/kernel/loongarch64/scopy_lasx.S new file mode 100644 index 000000000..7db1e7cee --- /dev/null +++ b/kernel/loongarch64/scopy_lasx.S @@ -0,0 +1,216 @@ +#define ASSEMBLER + +#include "common.h" +#define N $r4 +#define X $r5 +#define INCX $r6 +#define Y $r7 +#define INCY $r8 +#define I $r17 +#define TEMP $r18 +#define t1 $r14 +#define t2 $r15 +#define t3 $r16 +#define t4 $r19 +#define a1 $f12 +#define a2 $f13 +#define a3 $f14 +#define a4 $f15 +#define VX0 $xr12 +#define VX1 $xr13 + + PROLOGUE + bge $r0, N, .L999 + li.d TEMP, 1 + slli.d TEMP, TEMP, BASE_SHIFT + slli.d INCX, INCX, BASE_SHIFT + slli.d INCY, INCY, BASE_SHIFT + srai.d I, N, 3 + bne INCX, TEMP, .L20 + bne INCY, TEMP, .L12 // INCX==1 and INCY!=1 + b .L11 // INCX==1 and INCY==1 +.L20: + bne INCY, TEMP, .L22 // INCX!=1 and INCY!=1 + b .L21 // INCX!=1 and INCY==1 + +.L11: + bge $r0, I, .L112 + .align 3 + +.L111: + xvld VX0, X, 0 * SIZE + addi.d I, I, -1 + xvst VX0, Y, 0 * SIZE + addi.d X, X, 8 * SIZE + addi.d Y, Y, 8 * SIZE + blt $r0, I, .L111 + .align 3 + +.L112: + andi I, N, 7 + bge $r0, I, .L999 + .align 3 + +.L113: + fld.s $f12, X, 0 * SIZE + addi.d I, I, -1 + addi.d X, X, SIZE + fst.s $f12, Y, 0 * SIZE + addi.d Y, Y, SIZE + blt $r0, I, .L113 + b .L999 + .align 3 + +.L12: + bge $r0, I, .L122 + .align 3 + +.L121: + xvld VX0, X, 0 * SIZE + xvstelm.w VX0, Y, 0, 0 + add.d Y, Y, INCY + xvstelm.w VX0, Y, 0, 1 + add.d Y, Y, INCY + xvstelm.w VX0, Y, 0, 2 + add.d Y, Y, INCY + xvstelm.w VX0, Y, 0, 3 + add.d Y, Y, INCY + xvstelm.w VX0, Y, 0, 4 + add.d Y, Y, INCY + xvstelm.w VX0, Y, 0, 5 + add.d Y, Y, INCY + xvstelm.w VX0, Y, 0, 6 + add.d Y, Y, INCY + xvstelm.w VX0, Y, 0, 7 + add.d Y, Y, INCY + addi.d X, X, 8 * SIZE + addi.d I, I, -1 + blt $r0, I, .L121 + .align 3 + +.L122: + andi I, N, 7 + bge $r0, I, .L999 + .align 3 + +.L123: + fld.s $f12, X, 0 * SIZE + addi.d I, I, -1 + addi.d X, X, SIZE + fst.s $f12, Y, 0 * SIZE + add.d Y, Y, INCY + blt $r0, I, .L123 + b .L999 + .align 3 + +.L21: + bge $r0, I, .L212 + .align 3 + +.L211: + ld.w t1, X, 0 * SIZE + add.d X, X, INCX + ld.w t2, X, 0 * SIZE + add.d X, X, INCX + ld.w t3, X, 0 * SIZE + add.d X, X, INCX + ld.w t4, X, 0 * SIZE + add.d X, X, INCX + xvinsgr2vr.w VX0, t1, 0 + xvinsgr2vr.w VX0, t2, 1 + xvinsgr2vr.w VX0, t3, 2 + xvinsgr2vr.w VX0, t4, 3 + ld.w t1, X, 0 * SIZE + add.d X, X, INCX + ld.w t2, X, 0 * SIZE + add.d X, X, INCX + ld.w t3, X, 0 * SIZE + add.d X, X, INCX + ld.w t4, X, 0 * SIZE + add.d X, X, INCX + xvinsgr2vr.w VX0, t1, 4 + xvinsgr2vr.w VX0, t2, 5 + xvinsgr2vr.w VX0, t3, 6 + xvinsgr2vr.w VX0, t4, 7 + xvst VX0, Y, 0 * SIZE + addi.d Y, Y, 8 * SIZE + addi.d I, I, -1 + blt $r0, I, .L211 + .align 3 + +.L212: + andi I, N, 7 + bge $r0, I, .L999 + .align 3 + +.L213: + fld.s $f12, X, 0 * SIZE + addi.d I, I, -1 + fst.s $f12, Y, 0 * SIZE + add.d X, X, INCX + addi.d Y, Y, SIZE + blt $r0, I, .L213 + b .L999 + .align 3 + +.L22: + bge $r0, I, .L223 + .align 3 + +.L222: + fld.s a1, X, 0 * SIZE + add.d X, X, INCX + fld.s a2, X, 0 * SIZE + add.d X, X, INCX + fld.s a3, X, 0 * SIZE + add.d X, X, INCX + fld.s a4, X, 0 * SIZE + add.d X, X, INCX + fst.s a1, Y, 0 * SIZE + add.d Y, Y, INCY + fst.s a2, Y, 0 * SIZE + add.d Y, Y, INCY + fst.s a3, X, 0 * SIZE + add.d Y, Y, INCY + fst.s a4, X, 0 * SIZE + add.d Y, Y, INCY + fld.s a1, X, 0 * SIZE + add.d X, X, INCX + fld.s a2, X, 0 * SIZE + add.d X, X, INCX + fld.s a3, X, 0 * SIZE + add.d X, X, INCX + fld.s a4, X, 0 * SIZE + add.d X, X, INCX + fst.s a1, Y, 0 * SIZE + add.d Y, Y, INCY + fst.s a2, Y, 0 * SIZE + add.d Y, Y, INCY + fst.s a3, X, 0 * SIZE + add.d Y, Y, INCY + fst.s a4, X, 0 * SIZE + add.d Y, Y, INCY + addi.d I, I, -1 + blt $r0, I, .L222 + .align 3 + +.L223: + andi I, N, 7 + bge $r0, I, .L999 + .align 3 + +.L224: + fld.s $f12, X, 0 * SIZE + addi.d I, I, -1 + fst.s $f12, Y, 0 * SIZE + add.d X, X, INCX + add.d Y, Y, INCY + blt $r0, I, .L224 + .align 3 + +.L999: + move $r4, $r12 + jirl $r0, $r1, 0x0 + .align 3 + + EPILOGUE diff --git a/kernel/loongarch64/scopy_lsx.S b/kernel/loongarch64/scopy_lsx.S new file mode 100644 index 000000000..32150d3d6 --- /dev/null +++ b/kernel/loongarch64/scopy_lsx.S @@ -0,0 +1,220 @@ +#define ASSEMBLER + +#include "common.h" +#define N $r4 +#define X $r5 +#define INCX $r6 +#define Y $r7 +#define INCY $r8 +#define I $r17 +#define TEMP $r18 +#define t1 $r14 +#define t2 $r15 +#define t3 $r16 +#define t4 $r19 +#define a1 $f12 +#define a2 $f13 +#define a3 $f14 +#define a4 $f15 +#define VX0 $vr12 +#define VX1 $vr13 + + PROLOGUE + bge $r0, N, .L999 + li.d TEMP, 1 + slli.d TEMP, TEMP, BASE_SHIFT + slli.d INCX, INCX, BASE_SHIFT + slli.d INCY, INCY, BASE_SHIFT + srai.d I, N, 3 + bne INCX, TEMP, .L20 + bne INCY, TEMP, .L12 // INCX==1 and INCY!=1 + b .L11 // INCX==1 and INCY==1 +.L20: + bne INCY, TEMP, .L22 // INCX!=1 and INCY!=1 + b .L21 // INCX!=1 and INCY==1 + +.L11: + bge $r0, I, .L112 + .align 3 + +.L111: + vld VX0, X, 0 * SIZE + vld VX1, X, 4 * SIZE + addi.d I, I, -1 + vst VX0, Y, 0 * SIZE + vst VX1, Y, 4 * SIZE + addi.d X, X, 8 * SIZE + addi.d Y, Y, 8 * SIZE + blt $r0, I, .L111 + .align 3 + +.L112: + andi I, N, 7 + bge $r0, I, .L999 + .align 3 + +.L113: + fld.s $f12, X, 0 * SIZE + addi.d I, I, -1 + addi.d X, X, SIZE + fst.s $f12, Y, 0 * SIZE + addi.d Y, Y, SIZE + blt $r0, I, .L113 + b .L999 + .align 3 + +.L12: + bge $r0, I, .L122 + .align 3 + +.L121: + vld VX0, X, 0 * SIZE + vld VX1, X, 4 * SIZE + vstelm.w VX0, Y, 0, 0 + add.d Y, Y, INCY + vstelm.w VX0, Y, 0, 1 + add.d Y, Y, INCY + vstelm.w VX0, Y, 0, 2 + add.d Y, Y, INCY + vstelm.w VX0, Y, 0, 3 + add.d Y, Y, INCY + vstelm.w VX1, Y, 0, 0 + add.d Y, Y, INCY + vstelm.w VX1, Y, 0, 1 + add.d Y, Y, INCY + vstelm.w VX1, Y, 0, 2 + add.d Y, Y, INCY + vstelm.w VX1, Y, 0, 3 + add.d Y, Y, INCY + addi.d X, X, 8 * SIZE + addi.d I, I, -1 + blt $r0, I, .L121 + .align 3 + +.L122: + andi I, N, 7 + bge $r0, I, .L999 + .align 3 + +.L123: + fld.s $f12, X, 0 * SIZE + addi.d I, I, -1 + addi.d X, X, SIZE + fst.s $f12, Y, 0 * SIZE + add.d Y, Y, INCY + blt $r0, I, .L123 + b .L999 + .align 3 + +.L21: + bge $r0, I, .L212 + .align 3 + +.L211: + ld.w t1, X, 0 * SIZE + add.d X, X, INCX + ld.w t2, X, 0 * SIZE + add.d X, X, INCX + ld.w t3, X, 0 * SIZE + add.d X, X, INCX + ld.w t4, X, 0 * SIZE + add.d X, X, INCX + vinsgr2vr.w VX0, t1, 0 + vinsgr2vr.w VX0, t2, 1 + vinsgr2vr.w VX0, t3, 2 + vinsgr2vr.w VX0, t4, 3 + vst VX0, Y, 0 * SIZE + ld.w t1, X, 0 * SIZE + add.d X, X, INCX + ld.w t2, X, 0 * SIZE + add.d X, X, INCX + ld.w t3, X, 0 * SIZE + add.d X, X, INCX + ld.w t4, X, 0 * SIZE + add.d X, X, INCX + vinsgr2vr.w VX1, t1, 0 + vinsgr2vr.w VX1, t2, 1 + vinsgr2vr.w VX1, t3, 2 + vinsgr2vr.w VX1, t4, 3 + vst VX1, Y, 4 * SIZE + addi.d Y, Y, 8 * SIZE + addi.d I, I, -1 + blt $r0, I, .L211 + .align 3 + +.L212: + andi I, N, 7 + bge $r0, I, .L999 + .align 3 + +.L213: + fld.s $f12, X, 0 * SIZE + addi.d I, I, -1 + fst.s $f12, Y, 0 * SIZE + add.d X, X, INCX + addi.d Y, Y, SIZE + blt $r0, I, .L213 + b .L999 + .align 3 + +.L22: + bge $r0, I, .L223 + .align 3 + +.L222: + fld.s a1, X, 0 * SIZE + add.d X, X, INCX + fld.s a2, X, 0 * SIZE + add.d X, X, INCX + fld.s a3, X, 0 * SIZE + add.d X, X, INCX + fld.s a4, X, 0 * SIZE + add.d X, X, INCX + fst.s a1, Y, 0 * SIZE + add.d Y, Y, INCY + fst.s a2, Y, 0 * SIZE + add.d Y, Y, INCY + fst.s a3, X, 0 * SIZE + add.d Y, Y, INCY + fst.s a4, X, 0 * SIZE + add.d Y, Y, INCY + fld.s a1, X, 0 * SIZE + add.d X, X, INCX + fld.s a2, X, 0 * SIZE + add.d X, X, INCX + fld.s a3, X, 0 * SIZE + add.d X, X, INCX + fld.s a4, X, 0 * SIZE + add.d X, X, INCX + fst.s a1, Y, 0 * SIZE + add.d Y, Y, INCY + fst.s a2, Y, 0 * SIZE + add.d Y, Y, INCY + fst.s a3, X, 0 * SIZE + add.d Y, Y, INCY + fst.s a4, X, 0 * SIZE + add.d Y, Y, INCY + addi.d I, I, -1 + blt $r0, I, .L222 + .align 3 + +.L223: + andi I, N, 7 + bge $r0, I, .L999 + .align 3 + +.L224: + fld.s $f12, X, 0 * SIZE + addi.d I, I, -1 + fst.s $f12, Y, 0 * SIZE + add.d X, X, INCX + add.d Y, Y, INCY + blt $r0, I, .L224 + .align 3 + +.L999: + move $r4, $r12 + jirl $r0, $r1, 0x0 + .align 3 + + EPILOGUE From 360acc0a41dd2ec3fc461bac390c74c958525ae8 Mon Sep 17 00:00:00 2001 From: yancheng Date: Thu, 7 Dec 2023 12:57:05 +0800 Subject: [PATCH 53/60] loongarch64: Add optimizations for swap. --- kernel/loongarch64/KERNEL.LOONGSON2K1000 | 3 + kernel/loongarch64/KERNEL.LOONGSON3R5 | 3 + kernel/loongarch64/dswap_lasx.S | 301 +++++++++++++++++++++ kernel/loongarch64/dswap_lsx.S | 317 +++++++++++++++++++++++ kernel/loongarch64/sswap_lasx.S | 286 ++++++++++++++++++++ kernel/loongarch64/sswap_lsx.S | 294 +++++++++++++++++++++ 6 files changed, 1204 insertions(+) create mode 100644 kernel/loongarch64/dswap_lasx.S create mode 100644 kernel/loongarch64/dswap_lsx.S create mode 100644 kernel/loongarch64/sswap_lasx.S create mode 100644 kernel/loongarch64/sswap_lsx.S diff --git a/kernel/loongarch64/KERNEL.LOONGSON2K1000 b/kernel/loongarch64/KERNEL.LOONGSON2K1000 index 565bec0f2..879a6f68b 100644 --- a/kernel/loongarch64/KERNEL.LOONGSON2K1000 +++ b/kernel/loongarch64/KERNEL.LOONGSON2K1000 @@ -34,4 +34,7 @@ IDAMINKERNEL = idamin_lsx.S SCOPYKERNEL = scopy_lsx.S DCOPYKERNEL = dcopy_lsx.S +SSWAPKERNEL = sswap_lsx.S +DSWAPKERNEL = dswap_lsx.S + endif diff --git a/kernel/loongarch64/KERNEL.LOONGSON3R5 b/kernel/loongarch64/KERNEL.LOONGSON3R5 index a2443720b..581cfdbbe 100644 --- a/kernel/loongarch64/KERNEL.LOONGSON3R5 +++ b/kernel/loongarch64/KERNEL.LOONGSON3R5 @@ -34,6 +34,9 @@ IDAMINKERNEL = idamin_lasx.S SCOPYKERNEL = scopy_lasx.S DCOPYKERNEL = dcopy_lasx.S +SSWAPKERNEL = sswap_lasx.S +DSWAPKERNEL = dswap_lasx.S + DGEMMKERNEL = dgemm_kernel_16x4.S DGEMMINCOPY = dgemm_ncopy_16.S DGEMMITCOPY = dgemm_tcopy_16.S diff --git a/kernel/loongarch64/dswap_lasx.S b/kernel/loongarch64/dswap_lasx.S new file mode 100644 index 000000000..221cb7fa2 --- /dev/null +++ b/kernel/loongarch64/dswap_lasx.S @@ -0,0 +1,301 @@ +#define ASSEMBLER + +#include "common.h" +#define N $r4 +#define X $r7 +#define INCX $r8 +#define Y $r9 +#define INCY $r10 + +#define I $r17 +#define TEMP $r18 +#define XX $r5 +#define YY $r6 +#define t1 $r14 +#define t2 $r15 +#define t3 $r16 +#define t4 $r19 +#define a1 $f12 +#define a2 $f13 +#define a3 $f14 +#define a4 $f15 +#define b1 $f16 +#define b2 $f17 +#define b3 $f18 +#define b4 $f19 +#define VX0 $xr12 +#define VX1 $xr13 +#define VX2 $xr14 +#define VX3 $xr15 + + + PROLOGUE + bge $r0, N, .L999 + li.d TEMP, 1 + slli.d TEMP, TEMP, BASE_SHIFT + slli.d INCX, INCX, BASE_SHIFT + slli.d INCY, INCY, BASE_SHIFT + srai.d I, N, 3 + bne INCX, TEMP, .L20 + bne INCY, TEMP, .L12 // INCX==1 and INCY!=1 + b .L11 // INCX==1 and INCY==1 +.L20: + bne INCY, TEMP, .L22 // INCX!=1 and INCY!=1 + b .L21 // INCX!=1 and INCY==1 + +.L11: + bge $r0, I, .L112 + .align 3 + +.L111: + xvld VX0, X, 0 * SIZE + xvld VX1, X, 4 * SIZE + xvld VX2, Y, 0 * SIZE + xvld VX3, Y, 4 * SIZE + addi.d I, I, -1 + xvst VX2, X, 0 * SIZE + xvst VX3, X, 4 * SIZE + xvst VX0, Y, 0 * SIZE + xvst VX1, Y, 4 * SIZE + addi.d X, X, 8 * SIZE + addi.d Y, Y, 8 * SIZE + blt $r0, I, .L111 + .align 3 + +.L112: + andi I, N, 7 + bge $r0, I, .L999 + .align 3 + +.L113: + fld.d $f12, X, 0 * SIZE + fld.d $f14, Y, 0 * SIZE + addi.d I, I, -1 + fst.d $f12, Y, 0 * SIZE + fst.d $f14, X, 0 * SIZE + addi.d X, X, SIZE + addi.d Y, Y, SIZE + blt $r0, I, .L113 + b .L999 + .align 3 + +.L12: // INCX==1 and INCY!=1 + bge $r0, I, .L122 + .align 3 + +.L121: + xvld VX0, X, 0 * SIZE + ld.d t1, Y, 0 * SIZE + xvstelm.d VX0, Y, 0, 0 + add.d Y, Y, INCY + ld.d t2, Y, 0 * SIZE + xvstelm.d VX0, Y, 0, 1 + add.d Y, Y, INCY + ld.d t3, Y, 0 * SIZE + xvstelm.d VX0, Y, 0, 2 + add.d Y, Y, INCY + ld.d t4, Y, 0 * SIZE + xvstelm.d VX0, Y, 0, 3 + xvinsgr2vr.d VX2, t1, 0 + xvinsgr2vr.d VX2, t2, 1 + xvinsgr2vr.d VX2, t3, 2 + xvinsgr2vr.d VX2, t4, 3 + add.d Y, Y, INCY + xvst VX2, X, 0 * SIZE + xvld VX1, X, 4 * SIZE + ld.d t1, Y, 0 * SIZE + xvstelm.d VX1, Y, 0, 0 + add.d Y, Y, INCY + ld.d t2, Y, 0 * SIZE + xvstelm.d VX1, Y, 0, 1 + add.d Y, Y, INCY + ld.d t3, Y, 0 * SIZE + xvstelm.d VX1, Y, 0, 2 + add.d Y, Y, INCY + ld.d t4, Y, 0 * SIZE + xvstelm.d VX1, Y, 0, 3 + xvinsgr2vr.d VX3, t1, 0 + xvinsgr2vr.d VX3, t2, 1 + xvinsgr2vr.d VX3, t3, 2 + xvinsgr2vr.d VX3, t4, 3 + add.d Y, Y, INCY + xvst VX3, X, 4 * SIZE + addi.d X, X, 8 * SIZE + addi.d I, I, -1 + blt $r0, I, .L121 + .align 3 + +.L122: + andi I, N, 7 + bge $r0, I, .L999 + .align 3 + +.L123: + fld.d $f12, X, 0 * SIZE + fld.d $f14, Y, 0 * SIZE + addi.d I, I, -1 + fst.d $f12, Y, 0 * SIZE + fst.d $f14, X, 0 * SIZE + addi.d X, X, SIZE + add.d Y, Y, INCY + blt $r0, I, .L123 + b .L999 + .align 3 + +.L21: + bge $r0, I, .L212 + .align 3 + +.L211: + xvld VX2, Y, 0 * SIZE + ld.d t1, X, 0 * SIZE + xvstelm.d VX2, X, 0, 0 + add.d X, X, INCX + ld.d t2, X, 0 * SIZE + xvstelm.d VX2, X, 0, 1 + add.d X, X, INCX + ld.d t3, X, 0 * SIZE + xvstelm.d VX2, X, 0, 2 + add.d X, X, INCX + ld.d t4, X, 0 * SIZE + xvstelm.d VX2, X, 0, 3 + xvinsgr2vr.d VX0, t1, 0 + xvinsgr2vr.d VX0, t2, 1 + xvinsgr2vr.d VX0, t3, 2 + xvinsgr2vr.d VX0, t4, 3 + add.d X, X, INCX + xvst VX0, Y, 0 * SIZE + xvld VX3, Y, 4 * SIZE + ld.d t1, X, 0 * SIZE + xvstelm.d VX3, X, 0, 0 + add.d X, X, INCY + ld.d t2, X, 0 * SIZE + xvstelm.d VX3, X, 0, 1 + add.d X, X, INCX + ld.d t3, X, 0 * SIZE + xvstelm.d VX3, X, 0, 2 + add.d X, X, INCX + ld.d t4, X, 0 * SIZE + xvstelm.d VX3, X, 0, 3 + xvinsgr2vr.d VX1, t1, 0 + xvinsgr2vr.d VX1, t2, 1 + xvinsgr2vr.d VX1, t3, 2 + xvinsgr2vr.d VX1, t4, 3 + add.d X, X, INCX + xvst VX1, Y, 0 * SIZE + addi.d Y, Y, 8 * SIZE + addi.d I, I, -1 + blt $r0, I, .L211 + .align 3 + +.L212: + andi I, N, 7 + bge $r0, I, .L999 + .align 3 + +.L213: + fld.d $f12, X, 0 * SIZE + fld.d $f14, Y, 0 * SIZE + addi.d I, I, -1 + fst.d $f12, Y, 0 * SIZE + fst.d $f14, X, 0 * SIZE + add.d X, X, INCX + addi.d Y, Y, SIZE + blt $r0, I, .L213 + b .L999 + .align 3 + +.L22: + bgez INCX, .L220 + //addi.d TEMP, N, -1 + //mul.d TEMP, TEMP, INCX + //sub.d X, X, TEMP + .align 3 + +.L220: + bge $r0, I, .L223 + .align 3 + move XX, X + +.L222: + fld.d a1, X, 0 * SIZE + add.d X, X, INCX + fld.d a2, X, 0 * SIZE + add.d X, X, INCX + fld.d a3, X, 0 * SIZE + add.d X, X, INCX + fld.d a4, X, 0 * SIZE + add.d X, X, INCX + fld.d b1, Y, 0 * SIZE + fst.d a1, Y, 0 * SIZE + add.d Y, Y, INCY + fld.d b2, Y, 0 * SIZE + fst.d a2, Y, 0 * SIZE + add.d Y, Y, INCY + fld.d b3, Y, 0 * SIZE + fst.d a3, Y, 0 * SIZE + add.d Y, Y, INCY + fld.d b4, Y, 0 * SIZE + fst.d a4, Y, 0 * SIZE + add.d Y, Y, INCY + fld.d a1, X, 0 * SIZE + add.d X, X, INCX + fst.d b1, XX, 0 * SIZE + add.d XX, XX, INCX + fld.d b1, Y, 0 * SIZE + fst.d a1, Y, 0 * SIZE + add.d Y, Y, INCY + fld.d a2, X, 0 * SIZE + add.d X, X, INCX + fst.d b2, XX, 0 * SIZE + add.d XX, XX, INCX + fld.d b2, Y, 0 * SIZE + fst.d a2, Y, 0 * SIZE + add.d Y, Y, INCY + fld.d a3, X, 0 * SIZE + add.d X, X, INCX + fst.d b3, XX, 0 * SIZE + add.d XX, XX, INCX + fld.d b3, Y, 0 * SIZE + fst.d a3, Y, 0 * SIZE + fld.d a4, X, 0 * SIZE + add.d X, X, INCX + fst.d b4, XX, 0 * SIZE + add.d XX, XX, INCX + fld.d b4, Y, 0 * SIZE + fst.d a4, Y, 0 * SIZE + add.d Y, Y, INCY + fst.d b1, XX, 0 * SIZE + add.d XX, XX, INCX + fst.d b2, XX, 0 * SIZE + add.d XX, XX, INCX + fst.d b3, XX, 0 * SIZE + add.d XX, XX, INCX + fst.d b4, XX, 0 * SIZE + add.d XX, XX, INCX + addi.d I, I, -1 + blt $r0, I, .L222 + .align 3 + +.L223: + andi I, N, 7 + bge $r0, I, .L999 + .align 3 + +.L224: + fld.d $f12, X, 0 * SIZE + fld.d $f14, Y, 0 * SIZE + addi.d I, I, -1 + fst.d $f12, Y, 0 * SIZE + fst.d $f14, X, 0 * SIZE + add.d X, X, INCX + add.d Y, Y, INCY + blt $r0, I, .L224 + .align 3 + +.L999: + move $r4, $r12 + jirl $r0, $r1, 0x0 + .align 3 + + EPILOGUE diff --git a/kernel/loongarch64/dswap_lsx.S b/kernel/loongarch64/dswap_lsx.S new file mode 100644 index 000000000..7f7f585e1 --- /dev/null +++ b/kernel/loongarch64/dswap_lsx.S @@ -0,0 +1,317 @@ +#define ASSEMBLER + +#include "common.h" +#define N $r4 +#define X $r7 +#define INCX $r8 +#define Y $r9 +#define INCY $r10 + +#define I $r17 +#define TEMP $r18 +#define XX $r5 +#define YY $r6 +#define t1 $r14 +#define t2 $r15 +#define t3 $r16 +#define t4 $r19 +#define a1 $f12 +#define a2 $f13 +#define a3 $f14 +#define a4 $f15 +#define b1 $f16 +#define b2 $f17 +#define b3 $f18 +#define b4 $f19 +#define VX0 $vr12 +#define VX1 $vr13 +#define VX2 $vr14 +#define VX3 $vr15 + + + PROLOGUE + bge $r0, N, .L999 + li.d TEMP, 1 + slli.d TEMP, TEMP, BASE_SHIFT + slli.d INCX, INCX, BASE_SHIFT + slli.d INCY, INCY, BASE_SHIFT + srai.d I, N, 3 + bne INCX, TEMP, .L20 + bne INCY, TEMP, .L12 // INCX==1 and INCY!=1 + b .L11 // INCX==1 and INCY==1 +.L20: + bne INCY, TEMP, .L22 // INCX!=1 and INCY!=1 + b .L21 // INCX!=1 and INCY==1 + +.L11: + bge $r0, I, .L112 + .align 3 + +.L111: + vld VX0, X, 0 * SIZE + vld VX1, X, 2 * SIZE + vld VX2, Y, 0 * SIZE + vld VX3, Y, 2 * SIZE + vst VX2, X, 0 * SIZE + vst VX3, X, 2 * SIZE + vst VX0, Y, 0 * SIZE + vst VX1, Y, 2 * SIZE + vld VX0, X, 4 * SIZE + vld VX1, X, 6 * SIZE + vld VX2, Y, 4 * SIZE + vld VX3, Y, 6 * SIZE + addi.d I, I, -1 + vst VX2, X, 4 * SIZE + vst VX3, X, 6 * SIZE + vst VX0, Y, 4 * SIZE + vst VX1, Y, 6 * SIZE + addi.d X, X, 8 * SIZE + addi.d Y, Y, 8 * SIZE + blt $r0, I, .L111 + .align 3 + +.L112: + andi I, N, 7 + bge $r0, I, .L999 + .align 3 + +.L113: + fld.d $f12, X, 0 * SIZE + fld.d $f14, Y, 0 * SIZE + addi.d I, I, -1 + fst.d $f12, Y, 0 * SIZE + fst.d $f14, X, 0 * SIZE + addi.d X, X, SIZE + addi.d Y, Y, SIZE + blt $r0, I, .L113 + b .L999 + .align 3 + +.L12: // INCX==1 and INCY!=1 + bge $r0, I, .L122 + .align 3 + +.L121: + vld VX0, X, 0 * SIZE + ld.d t1, Y, 0 * SIZE + vstelm.d VX0, Y, 0, 0 + add.d Y, Y, INCY + ld.d t2, Y, 0 * SIZE + vstelm.d VX0, Y, 0, 1 + vinsgr2vr.d VX2, t1, 0 + vinsgr2vr.d VX2, t2, 1 + add.d Y, Y, INCY + vst VX2, X, 0 * SIZE + vld VX1, X, 2 * SIZE + ld.d t3, Y, 0 * SIZE + vstelm.d VX1, Y, 0, 0 + add.d Y, Y, INCY + ld.d t4, Y, 0 * SIZE + vstelm.d VX1, Y, 0, 1 + vinsgr2vr.d VX3, t3, 0 + vinsgr2vr.d VX3, t4, 1 + add.d Y, Y, INCY + vst VX3, X, 2 * SIZE + vld VX0, X, 4 * SIZE + ld.d t1, Y, 0 * SIZE + vstelm.d VX0, Y, 0, 0 + add.d Y, Y, INCY + ld.d t2, Y, 0 * SIZE + vstelm.d VX0, Y, 0, 1 + vinsgr2vr.d VX2, t1, 0 + vinsgr2vr.d VX2, t2, 1 + add.d Y, Y, INCY + vst VX2, X, 4 * SIZE + vld VX1, X, 6 * SIZE + ld.d t3, Y, 0 * SIZE + vstelm.d VX1, Y, 0, 0 + add.d Y, Y, INCY + ld.d t4, Y, 0 * SIZE + vstelm.d VX1, Y, 0, 1 + vinsgr2vr.d VX3, t3, 0 + vinsgr2vr.d VX3, t4, 1 + add.d Y, Y, INCY + vst VX3, X, 6 * SIZE + addi.d X, X, 8 * SIZE + addi.d I, I, -1 + blt $r0, I, .L121 + .align 3 + +.L122: + andi I, N, 7 + bge $r0, I, .L999 + .align 3 + +.L123: + fld.d $f12, X, 0 * SIZE + fld.d $f14, Y, 0 * SIZE + addi.d I, I, -1 + fst.d $f12, Y, 0 * SIZE + fst.d $f14, X, 0 * SIZE + addi.d X, X, SIZE + add.d Y, Y, INCY + blt $r0, I, .L123 + b .L999 + .align 3 + +.L21: + bge $r0, I, .L212 + .align 3 + +.L211: + vld VX2, Y, 0 * SIZE + ld.d t1, X, 0 * SIZE + vstelm.d VX2, X, 0, 0 + add.d X, X, INCX + ld.d t2, X, 0 * SIZE + vstelm.d VX2, X, 0, 1 + vinsgr2vr.d VX0, t1, 0 + vinsgr2vr.d VX0, t2, 1 + add.d X, X, INCY + vst VX0, Y, 0 * SIZE + vld VX3, Y, 2 * SIZE + ld.d t3, X, 0 * SIZE + vstelm.d VX3, X, 0, 0 + add.d X, X, INCX + ld.d t4, X, 0 * SIZE + vstelm.d VX3, X, 0, 1 + vinsgr2vr.d VX1, t3, 0 + vinsgr2vr.d VX1, t4, 1 + add.d X, X, INCX + vst VX1, Y, 2 * SIZE + vld VX2, Y, 4 * SIZE + ld.d t1, X, 0 * SIZE + vstelm.d VX2, X, 0, 0 + add.d X, X, INCX + ld.d t2, X, 0 * SIZE + vstelm.d VX2, X, 0, 1 + vinsgr2vr.d VX0, t1, 0 + vinsgr2vr.d VX0, t2, 1 + add.d X, X, INCY + vst VX0, Y, 4 * SIZE + vld VX3, Y, 6 * SIZE + ld.d t3, X, 0 * SIZE + vstelm.d VX3, X, 0, 0 + add.d X, X, INCX + ld.d t4, X, 0 * SIZE + vstelm.d VX3, X, 0, 1 + vinsgr2vr.d VX1, t3, 0 + vinsgr2vr.d VX1, t4, 1 + add.d X, X, INCX + vst VX1, Y, 6 * SIZE + addi.d Y, Y, 8 * SIZE + addi.d I, I, -1 + blt $r0, I, .L211 + .align 3 + +.L212: + andi I, N, 7 + bge $r0, I, .L999 + .align 3 + +.L213: + fld.d $f12, X, 0 * SIZE + fld.d $f14, Y, 0 * SIZE + addi.d I, I, -1 + fst.d $f12, Y, 0 * SIZE + fst.d $f14, X, 0 * SIZE + add.d X, X, INCX + addi.d Y, Y, SIZE + blt $r0, I, .L213 + b .L999 + .align 3 + +.L22: + bgez INCX, .L220 + //addi.d TEMP, N, -1 + //mul.d TEMP, TEMP, INCX + //sub.d X, X, TEMP + .align 3 + +.L220: + bge $r0, I, .L223 + .align 3 + move XX, X + +.L222: + fld.d a1, X, 0 * SIZE + add.d X, X, INCX + fld.d a2, X, 0 * SIZE + add.d X, X, INCX + fld.d a3, X, 0 * SIZE + add.d X, X, INCX + fld.d a4, X, 0 * SIZE + add.d X, X, INCX + fld.d b1, Y, 0 * SIZE + fst.d a1, Y, 0 * SIZE + add.d Y, Y, INCY + fld.d b2, Y, 0 * SIZE + fst.d a2, Y, 0 * SIZE + add.d Y, Y, INCY + fld.d b3, Y, 0 * SIZE + fst.d a3, Y, 0 * SIZE + add.d Y, Y, INCY + fld.d b4, Y, 0 * SIZE + fst.d a4, Y, 0 * SIZE + add.d Y, Y, INCY + fld.d a1, X, 0 * SIZE + add.d X, X, INCX + fst.d b1, XX, 0 * SIZE + add.d XX, XX, INCX + fld.d b1, Y, 0 * SIZE + fst.d a1, Y, 0 * SIZE + add.d Y, Y, INCY + fld.d a2, X, 0 * SIZE + add.d X, X, INCX + fst.d b2, XX, 0 * SIZE + add.d XX, XX, INCX + fld.d b2, Y, 0 * SIZE + fst.d a2, Y, 0 * SIZE + add.d Y, Y, INCY + fld.d a3, X, 0 * SIZE + add.d X, X, INCX + fst.d b3, XX, 0 * SIZE + add.d XX, XX, INCX + fld.d b3, Y, 0 * SIZE + fst.d a3, Y, 0 * SIZE + fld.d a4, X, 0 * SIZE + add.d X, X, INCX + fst.d b4, XX, 0 * SIZE + add.d XX, XX, INCX + fld.d b4, Y, 0 * SIZE + fst.d a4, Y, 0 * SIZE + add.d Y, Y, INCY + fst.d b1, XX, 0 * SIZE + add.d XX, XX, INCX + fst.d b2, XX, 0 * SIZE + add.d XX, XX, INCX + fst.d b3, XX, 0 * SIZE + add.d XX, XX, INCX + fst.d b4, XX, 0 * SIZE + add.d XX, XX, INCX + addi.d I, I, -1 + blt $r0, I, .L222 + .align 3 + +.L223: + andi I, N, 7 + bge $r0, I, .L999 + .align 3 + +.L224: + fld.d $f12, X, 0 * SIZE + fld.d $f14, Y, 0 * SIZE + addi.d I, I, -1 + fst.d $f12, Y, 0 * SIZE + fst.d $f14, X, 0 * SIZE + add.d X, X, INCX + add.d Y, Y, INCY + blt $r0, I, .L224 + .align 3 + +.L999: + move $r4, $r12 + jirl $r0, $r1, 0x0 + .align 3 + + EPILOGUE diff --git a/kernel/loongarch64/sswap_lasx.S b/kernel/loongarch64/sswap_lasx.S new file mode 100644 index 000000000..7184eff45 --- /dev/null +++ b/kernel/loongarch64/sswap_lasx.S @@ -0,0 +1,286 @@ +#define ASSEMBLER + +#include "common.h" +#define N $r4 +#define X $r7 +#define INCX $r8 +#define Y $r9 +#define INCY $r10 + +#define I $r17 +#define TEMP $r18 +#define XX $r5 +#define YY $r6 +#define t1 $r14 +#define t2 $r15 +#define t3 $r16 +#define t4 $r19 +#define a1 $f12 +#define a2 $f13 +#define a3 $f14 +#define a4 $f15 +#define b1 $f16 +#define b2 $f17 +#define b3 $f18 +#define b4 $f19 +#define VX0 $xr12 +#define VX1 $xr13 +#define VX2 $xr14 +#define VX3 $xr15 + + + PROLOGUE + bge $r0, N, .L999 + li.d TEMP, 1 + slli.d TEMP, TEMP, BASE_SHIFT + slli.d INCX, INCX, BASE_SHIFT + slli.d INCY, INCY, BASE_SHIFT + srai.d I, N, 3 + bne INCX, TEMP, .L20 + bne INCY, TEMP, .L12 // INCX==1 and INCY!=1 + b .L11 // INCX==1 and INCY==1 +.L20: + bne INCY, TEMP, .L22 // INCX!=1 and INCY!=1 + b .L21 // INCX!=1 and INCY==1 + +.L11: + bge $r0, I, .L112 + .align 3 + +.L111: + xvld VX0, X, 0 * SIZE + xvld VX2, Y, 0 * SIZE + addi.d I, I, -1 + xvst VX2, X, 0 * SIZE + xvst VX0, Y, 0 * SIZE + addi.d X, X, 8 * SIZE + addi.d Y, Y, 8 * SIZE + blt $r0, I, .L111 + .align 3 + +.L112: + andi I, N, 7 + bge $r0, I, .L999 + .align 3 + +.L113: + fld.s $f12, X, 0 * SIZE + fld.s $f14, Y, 0 * SIZE + addi.d I, I, -1 + fst.s $f12, Y, 0 * SIZE + fst.s $f14, X, 0 * SIZE + addi.d X, X, SIZE + addi.d Y, Y, SIZE + blt $r0, I, .L113 + b .L999 + .align 3 + +.L12: // INCX==1 and INCY!=1 + bge $r0, I, .L122 + .align 3 + +.L121: + xvld VX0, X, 0 * SIZE + ld.w t1, Y, 0 * SIZE + xvstelm.w VX0, Y, 0, 0 + add.d Y, Y, INCY + ld.w t2, Y, 0 * SIZE + xvstelm.w VX0, Y, 0, 1 + add.d Y, Y, INCY + ld.w t3, Y, 0 * SIZE + xvstelm.w VX0, Y, 0, 2 + add.d Y, Y, INCY + ld.w t4, Y, 0 * SIZE + xvstelm.w VX0, Y, 0, 3 + xvinsgr2vr.w VX2, t1, 0 + xvinsgr2vr.w VX2, t2, 1 + xvinsgr2vr.w VX2, t3, 2 + xvinsgr2vr.w VX2, t4, 3 + add.d Y, Y, INCY + ld.w t1, Y, 0 * SIZE + xvstelm.w VX0, Y, 0, 4 + add.d Y, Y, INCY + ld.w t2, Y, 0 * SIZE + xvstelm.w VX0, Y, 0, 5 + add.d Y, Y, INCY + ld.w t3, Y, 0 * SIZE + xvstelm.w VX0, Y, 0, 6 + add.d Y, Y, INCY + ld.w t4, Y, 0 * SIZE + xvstelm.w VX0, Y, 0, 7 + xvinsgr2vr.w VX2, t1, 4 + xvinsgr2vr.w VX2, t2, 5 + xvinsgr2vr.w VX2, t3, 6 + xvinsgr2vr.w VX2, t4, 7 + add.d Y, Y, INCY + xvst VX2, X, 0 * SIZE + addi.d X, X, 8 * SIZE + addi.d I, I, -1 + blt $r0, I, .L121 + .align 3 + +.L122: + andi I, N, 7 + bge $r0, I, .L999 + .align 3 + +.L123: + fld.s $f12, X, 0 * SIZE + fld.s $f14, Y, 0 * SIZE + addi.d I, I, -1 + fst.s $f12, Y, 0 * SIZE + fst.s $f14, X, 0 * SIZE + addi.d X, X, SIZE + add.d Y, Y, INCY + blt $r0, I, .L123 + b .L999 + .align 3 + +.L21: + bge $r0, I, .L212 + .align 3 + +.L211: + xvld VX2, Y, 0 * SIZE + ld.w t1, X, 0 * SIZE + xvstelm.w VX2, X, 0, 0 + add.d X, X, INCX + ld.w t2, X, 0 * SIZE + xvstelm.w VX2, X, 0, 1 + add.d X, X, INCY + ld.w t3, X, 0 * SIZE + xvstelm.w VX2, X, 0, 2 + add.d X, X, INCX + ld.w t4, X, 0 * SIZE + xvstelm.w VX2, X, 0, 3 + xvinsgr2vr.w VX0, t1, 0 + xvinsgr2vr.w VX0, t2, 1 + xvinsgr2vr.w VX0, t3, 2 + xvinsgr2vr.w VX0, t4, 3 + add.d X, X, INCX + ld.w t1, X, 0 * SIZE + xvstelm.w VX2, X, 0, 4 + add.d X, X, INCY + ld.w t2, X, 0 * SIZE + xvstelm.w VX2, X, 0, 5 + add.d X, X, INCX + ld.w t3, X, 0 * SIZE + xvstelm.w VX2, X, 0, 6 + add.d X, X, INCX + ld.w t4, X, 0 * SIZE + xvstelm.w VX2, X, 0, 7 + xvinsgr2vr.w VX0, t1, 4 + xvinsgr2vr.w VX0, t2, 5 + xvinsgr2vr.w VX0, t3, 6 + xvinsgr2vr.w VX0, t4, 7 + add.d X, X, INCX + xvst VX1, Y, 0 * SIZE + addi.d Y, Y, 8 * SIZE + addi.d I, I, -1 + blt $r0, I, .L211 + .align 3 + +.L212: + andi I, N, 7 + bge $r0, I, .L999 + .align 3 + +.L213: + fld.s $f12, X, 0 * SIZE + fld.s $f14, Y, 0 * SIZE + addi.d I, I, -1 + fst.s $f12, Y, 0 * SIZE + fst.s $f14, X, 0 * SIZE + add.d X, X, INCX + addi.d Y, Y, SIZE + blt $r0, I, .L213 + b .L999 + .align 3 + +.L22: + bge $r0, I, .L223 + .align 3 + move XX, X + +.L222: + fld.s a1, X, 0 * SIZE + add.d X, X, INCX + fld.s a2, X, 0 * SIZE + add.d X, X, INCX + fld.s a3, X, 0 * SIZE + add.d X, X, INCX + fld.s a4, X, 0 * SIZE + add.d X, X, INCX + fld.s b1, Y, 0 * SIZE + fst.s a1, Y, 0 * SIZE + add.d Y, Y, INCY + fld.s b2, Y, 0 * SIZE + fst.s a2, Y, 0 * SIZE + add.d Y, Y, INCY + fld.s b3, Y, 0 * SIZE + fst.s a3, Y, 0 * SIZE + add.d Y, Y, INCY + fld.s b4, Y, 0 * SIZE + fst.s a4, Y, 0 * SIZE + add.d Y, Y, INCY + fld.s a1, X, 0 * SIZE + add.d X, X, INCX + fst.s b1, XX, 0 * SIZE + add.d XX, XX, INCX + fld.s b1, Y, 0 * SIZE + fst.s a1, Y, 0 * SIZE + add.d Y, Y, INCY + fld.s a2, X, 0 * SIZE + add.d X, X, INCX + fst.s b2, XX, 0 * SIZE + add.d XX, XX, INCX + fld.s b2, Y, 0 * SIZE + fst.s a2, Y, 0 * SIZE + add.d Y, Y, INCY + fld.s a3, X, 0 * SIZE + add.d X, X, INCX + fst.s b3, XX, 0 * SIZE + add.d XX, XX, INCX + fld.s b3, Y, 0 * SIZE + fst.s a3, Y, 0 * SIZE + fld.s a4, X, 0 * SIZE + add.d X, X, INCX + fst.s b4, XX, 0 * SIZE + add.d XX, XX, INCX + fld.s b4, Y, 0 * SIZE + fst.s a4, Y, 0 * SIZE + add.d Y, Y, INCY + fst.s b1, XX, 0 * SIZE + add.d XX, XX, INCX + fst.s b2, XX, 0 * SIZE + add.d XX, XX, INCX + fst.s b3, XX, 0 * SIZE + add.d XX, XX, INCX + fst.s b4, XX, 0 * SIZE + add.d XX, XX, INCX + addi.d I, I, -1 + blt $r0, I, .L222 + .align 3 + +.L223: + andi I, N, 7 + bge $r0, I, .L999 + .align 3 + +.L224: + fld.s $f12, X, 0 * SIZE + fld.s $f14, Y, 0 * SIZE + addi.d I, I, -1 + fst.s $f12, Y, 0 * SIZE + fst.s $f14, X, 0 * SIZE + add.d X, X, INCX + add.d Y, Y, INCY + blt $r0, I, .L224 + .align 3 + +.L999: + move $r4, $r12 + jirl $r0, $r1, 0x0 + .align 3 + + EPILOGUE diff --git a/kernel/loongarch64/sswap_lsx.S b/kernel/loongarch64/sswap_lsx.S new file mode 100644 index 000000000..4f19a8024 --- /dev/null +++ b/kernel/loongarch64/sswap_lsx.S @@ -0,0 +1,294 @@ +#define ASSEMBLER + +#include "common.h" +#define N $r4 +#define X $r7 +#define INCX $r8 +#define Y $r9 +#define INCY $r10 + +#define I $r17 +#define TEMP $r18 +#define XX $r5 +#define YY $r6 +#define t1 $r14 +#define t2 $r15 +#define t3 $r16 +#define t4 $r19 +#define a1 $f12 +#define a2 $f13 +#define a3 $f14 +#define a4 $f15 +#define b1 $f16 +#define b2 $f17 +#define b3 $f18 +#define b4 $f19 +#define VX0 $vr12 +#define VX1 $vr13 +#define VX2 $vr14 +#define VX3 $vr15 + + + PROLOGUE + bge $r0, N, .L999 + li.d TEMP, 1 + slli.d TEMP, TEMP, BASE_SHIFT + slli.d INCX, INCX, BASE_SHIFT + slli.d INCY, INCY, BASE_SHIFT + srai.d I, N, 3 + bne INCX, TEMP, .L20 + bne INCY, TEMP, .L12 // INCX==1 and INCY!=1 + b .L11 // INCX==1 and INCY==1 +.L20: + bne INCY, TEMP, .L22 // INCX!=1 and INCY!=1 + b .L21 // INCX!=1 and INCY==1 + +.L11: + bge $r0, I, .L112 + .align 3 + +.L111: + vld VX0, X, 0 * SIZE + vld VX1, X, 4 * SIZE + vld VX2, Y, 0 * SIZE + vld VX3, Y, 4 * SIZE + addi.d I, I, -1 + vst VX2, X, 0 * SIZE + vst VX3, X, 4 * SIZE + vst VX0, Y, 0 * SIZE + vst VX1, Y, 4 * SIZE + addi.d X, X, 8 * SIZE + addi.d Y, Y, 8 * SIZE + blt $r0, I, .L111 + .align 3 + +.L112: + andi I, N, 7 + bge $r0, I, .L999 + .align 3 + +.L113: + fld.s $f12, X, 0 * SIZE + fld.s $f14, Y, 0 * SIZE + addi.d I, I, -1 + fst.s $f12, Y, 0 * SIZE + fst.s $f14, X, 0 * SIZE + addi.d X, X, SIZE + addi.d Y, Y, SIZE + blt $r0, I, .L113 + b .L999 + .align 3 + +.L12: // INCX==1 and INCY!=1 + bge $r0, I, .L122 + .align 3 + +.L121: + vld VX0, X, 0 * SIZE + ld.w t1, Y, 0 * SIZE + vstelm.w VX0, Y, 0, 0 + add.d Y, Y, INCY + ld.w t2, Y, 0 * SIZE + vstelm.w VX0, Y, 0, 1 + add.d Y, Y, INCY + ld.w t3, Y, 0 * SIZE + vstelm.w VX0, Y, 0, 2 + add.d Y, Y, INCY + ld.w t4, Y, 0 * SIZE + vstelm.w VX0, Y, 0, 3 + vinsgr2vr.w VX2, t1, 0 + vinsgr2vr.w VX2, t2, 1 + vinsgr2vr.w VX2, t3, 2 + vinsgr2vr.w VX2, t4, 3 + add.d Y, Y, INCY + vst VX2, X, 0 * SIZE + vld VX1, X, 4 * SIZE + ld.w t1, Y, 0 * SIZE + vstelm.w VX1, Y, 0, 0 + add.d Y, Y, INCY + ld.w t2, Y, 0 * SIZE + vstelm.w VX1, Y, 0, 1 + add.d Y, Y, INCY + ld.w t3, Y, 0 * SIZE + vstelm.w VX1, Y, 0, 2 + add.d Y, Y, INCY + ld.w t4, Y, 0 * SIZE + vstelm.w VX1, Y, 0, 3 + vinsgr2vr.w VX3, t1, 0 + vinsgr2vr.w VX3, t2, 1 + vinsgr2vr.w VX3, t3, 2 + vinsgr2vr.w VX3, t4, 3 + add.d Y, Y, INCY + vst VX3, X, 4 * SIZE + addi.d X, X, 8 * SIZE + addi.d I, I, -1 + blt $r0, I, .L121 + .align 3 + +.L122: + andi I, N, 7 + bge $r0, I, .L999 + .align 3 + +.L123: + fld.s $f12, X, 0 * SIZE + fld.s $f14, Y, 0 * SIZE + addi.d I, I, -1 + fst.s $f12, Y, 0 * SIZE + fst.s $f14, X, 0 * SIZE + addi.d X, X, SIZE + add.d Y, Y, INCY + blt $r0, I, .L123 + b .L999 + .align 3 + +.L21:// INCX!=1 and INCY==1 + bge $r0, I, .L212 + .align 3 + +.L211: + vld VX2, Y, 0 * SIZE + ld.w t1, X, 0 * SIZE + vstelm.w VX2, X, 0, 0 + add.d X, X, INCX + ld.w t2, X, 0 * SIZE + vstelm.w VX2, X, 0, 1 + add.d X, X, INCY + ld.w t3, X, 0 * SIZE + vstelm.w VX2, X, 0, 2 + add.d X, X, INCX + ld.w t4, X, 0 * SIZE + vstelm.w VX2, X, 0, 3 + vinsgr2vr.w VX0, t1, 0 + vinsgr2vr.w VX0, t2, 1 + vinsgr2vr.w VX0, t3, 2 + vinsgr2vr.w VX0, t4, 3 + add.d X, X, INCX + vst VX0, Y, 0 * SIZE + vld VX3, Y, 4 * SIZE + ld.w t1, X, 0 * SIZE + vstelm.w VX3, X, 0, 0 + add.d X, X, INCY + ld.w t2, X, 0 * SIZE + vstelm.w VX3, X, 0, 1 + add.d X, X, INCX + ld.w t3, X, 0 * SIZE + vstelm.w VX3, X, 0, 2 + add.d X, X, INCX + ld.w t4, X, 0 * SIZE + vstelm.w VX3, X, 0, 3 + vinsgr2vr.w VX1, t1, 0 + vinsgr2vr.w VX1, t2, 1 + vinsgr2vr.w VX1, t3, 2 + vinsgr2vr.w VX1, t4, 3 + add.d X, X, INCX + vst VX1, Y, 0 * SIZE + addi.d Y, Y, 8 * SIZE + addi.d I, I, -1 + blt $r0, I, .L211 + .align 3 + +.L212: + andi I, N, 7 + bge $r0, I, .L999 + .align 3 + +.L213: + fld.s $f12, X, 0 * SIZE + fld.s $f14, Y, 0 * SIZE + addi.d I, I, -1 + fst.s $f12, Y, 0 * SIZE + fst.s $f14, X, 0 * SIZE + add.d X, X, INCX + addi.d Y, Y, SIZE + blt $r0, I, .L213 + b .L999 + .align 3 + +.L22: + bge $r0, I, .L223 + .align 3 + move XX, X + +.L222: + fld.s a1, X, 0 * SIZE + add.d X, X, INCX + fld.s a2, X, 0 * SIZE + add.d X, X, INCX + fld.s a3, X, 0 * SIZE + add.d X, X, INCX + fld.s a4, X, 0 * SIZE + add.d X, X, INCX + fld.s b1, Y, 0 * SIZE + fst.s a1, Y, 0 * SIZE + add.d Y, Y, INCY + fld.s b2, Y, 0 * SIZE + fst.s a2, Y, 0 * SIZE + add.d Y, Y, INCY + fld.s b3, Y, 0 * SIZE + fst.s a3, Y, 0 * SIZE + add.d Y, Y, INCY + fld.s b4, Y, 0 * SIZE + fst.s a4, Y, 0 * SIZE + add.d Y, Y, INCY + fld.s a1, X, 0 * SIZE + add.d X, X, INCX + fst.s b1, XX, 0 * SIZE + add.d XX, XX, INCX + fld.s b1, Y, 0 * SIZE + fst.s a1, Y, 0 * SIZE + add.d Y, Y, INCY + fld.s a2, X, 0 * SIZE + add.d X, X, INCX + fst.s b2, XX, 0 * SIZE + add.d XX, XX, INCX + fld.s b2, Y, 0 * SIZE + fst.s a2, Y, 0 * SIZE + add.d Y, Y, INCY + fld.s a3, X, 0 * SIZE + add.d X, X, INCX + fst.s b3, XX, 0 * SIZE + add.d XX, XX, INCX + fld.s b3, Y, 0 * SIZE + fst.s a3, Y, 0 * SIZE + fld.s a4, X, 0 * SIZE + add.d X, X, INCX + fst.s b4, XX, 0 * SIZE + add.d XX, XX, INCX + fld.s b4, Y, 0 * SIZE + fst.s a4, Y, 0 * SIZE + add.d Y, Y, INCY + fst.s b1, XX, 0 * SIZE + add.d XX, XX, INCX + fst.s b2, XX, 0 * SIZE + add.d XX, XX, INCX + fst.s b3, XX, 0 * SIZE + add.d XX, XX, INCX + fst.s b4, XX, 0 * SIZE + add.d XX, XX, INCX + addi.d I, I, -1 + blt $r0, I, .L222 + .align 3 + +.L223: + andi I, N, 7 + bge $r0, I, .L999 + .align 3 + +.L224: + fld.s $f12, X, 0 * SIZE + fld.s $f14, Y, 0 * SIZE + addi.d I, I, -1 + fst.s $f12, Y, 0 * SIZE + fst.s $f14, X, 0 * SIZE + add.d X, X, INCX + add.d Y, Y, INCY + blt $r0, I, .L224 + .align 3 + +.L999: + move $r4, $r12 + jirl $r0, $r1, 0x0 + .align 3 + + EPILOGUE From d4c96a35a80da33c9d71fc5dd291f05f55900e27 Mon Sep 17 00:00:00 2001 From: yancheng Date: Thu, 7 Dec 2023 13:02:03 +0800 Subject: [PATCH 54/60] loongarch64: Add optimizations for axpy and axpby. --- kernel/loongarch64/KERNEL.LOONGSON2K1000 | 6 + kernel/loongarch64/KERNEL.LOONGSON3R5 | 6 + kernel/loongarch64/daxpby_lasx.S | 629 ++++++++++++++++++++ kernel/loongarch64/daxpby_lsx.S | 693 +++++++++++++++++++++++ kernel/loongarch64/daxpy_lasx.S | 338 +++++++++++ kernel/loongarch64/daxpy_lsx.S | 365 ++++++++++++ kernel/loongarch64/saxpby_lasx.S | 597 +++++++++++++++++++ kernel/loongarch64/saxpby_lsx.S | 629 ++++++++++++++++++++ kernel/loongarch64/saxpy_lasx.S | 323 +++++++++++ kernel/loongarch64/saxpy_lsx.S | 338 +++++++++++ 10 files changed, 3924 insertions(+) create mode 100644 kernel/loongarch64/daxpby_lasx.S create mode 100644 kernel/loongarch64/daxpby_lsx.S create mode 100644 kernel/loongarch64/daxpy_lasx.S create mode 100644 kernel/loongarch64/daxpy_lsx.S create mode 100644 kernel/loongarch64/saxpby_lasx.S create mode 100644 kernel/loongarch64/saxpby_lsx.S create mode 100644 kernel/loongarch64/saxpy_lasx.S create mode 100644 kernel/loongarch64/saxpy_lsx.S diff --git a/kernel/loongarch64/KERNEL.LOONGSON2K1000 b/kernel/loongarch64/KERNEL.LOONGSON2K1000 index 879a6f68b..a94303151 100644 --- a/kernel/loongarch64/KERNEL.LOONGSON2K1000 +++ b/kernel/loongarch64/KERNEL.LOONGSON2K1000 @@ -37,4 +37,10 @@ DCOPYKERNEL = dcopy_lsx.S SSWAPKERNEL = sswap_lsx.S DSWAPKERNEL = dswap_lsx.S +SAXPYKERNEL = saxpy_lsx.S +DAXPYKERNEL = daxpy_lsx.S + +SAXPBYKERNEL = saxpby_lsx.S +DAXPBYKERNEL = daxpby_lsx.S + endif diff --git a/kernel/loongarch64/KERNEL.LOONGSON3R5 b/kernel/loongarch64/KERNEL.LOONGSON3R5 index 581cfdbbe..4cfd53058 100644 --- a/kernel/loongarch64/KERNEL.LOONGSON3R5 +++ b/kernel/loongarch64/KERNEL.LOONGSON3R5 @@ -37,6 +37,12 @@ DCOPYKERNEL = dcopy_lasx.S SSWAPKERNEL = sswap_lasx.S DSWAPKERNEL = dswap_lasx.S +SAXPYKERNEL = saxpy_lasx.S +DAXPYKERNEL = daxpy_lasx.S + +SAXPBYKERNEL = saxpby_lasx.S +DAXPBYKERNEL = daxpby_lasx.S + DGEMMKERNEL = dgemm_kernel_16x4.S DGEMMINCOPY = dgemm_ncopy_16.S DGEMMITCOPY = dgemm_tcopy_16.S diff --git a/kernel/loongarch64/daxpby_lasx.S b/kernel/loongarch64/daxpby_lasx.S new file mode 100644 index 000000000..4b19703e7 --- /dev/null +++ b/kernel/loongarch64/daxpby_lasx.S @@ -0,0 +1,629 @@ +#define ASSEMBLER + +#include "common.h" +#define N $r4 +#define ALPHA $f0 +#define X $r5 +#define INCX $r6 +#define BETA $f1 +#define Y $r7 +#define INCY $r8 + +#define I $r12 +#define TEMP $r13 +#define t1 $r14 +#define t2 $r16 +#define t3 $r15 +#define t4 $r17 +#define XX $r18 +#define YY $r19 +#define a1 $f12 +#define a2 $f13 +#define VX0 $xr8 +#define VX1 $xr20 +#define VX2 $xr21 +#define VX3 $xr22 +#define VXA $xr23 +#define VXB $xr9 +#define VXZ $xr19 + + PROLOGUE + + bge $r0, N, .L999 + li.d TEMP, 1 + movgr2fr.d a1, $r0 + ffint.d.l a1, a1 + slli.d TEMP, TEMP, BASE_SHIFT + slli.d INCX, INCX, BASE_SHIFT + slli.d INCY, INCY, BASE_SHIFT + movfr2gr.d t1, ALPHA + xvreplgr2vr.d VXA, t1 + movfr2gr.d t2, BETA + xvreplgr2vr.d VXB, t2 + movfr2gr.d t3, a1 + xvreplgr2vr.d VXZ, t3 + srai.d I, N, 3 + bne INCX, TEMP, .L20 + bne INCY, TEMP, .L12 // INCX==1 and INCY!=1 + b .L11 // INCX==1 and INCY==1 +.L20: + bne INCY, TEMP, .L22 // INCX!=1 and INCY!=1 + b .L21 // INCX!=1 and INCY==1 + +.L11: + bge $r0, I, .L997 + fcmp.ceq.d $fcc0, ALPHA, a1 + bcnez $fcc0, .L110 + fcmp.ceq.d $fcc0, BETA, a1 + bcnez $fcc0, .L112 // ALPHA!=0 BETA==0 + b .L111 // ALPHA!=0 BETA!=0 + .align 3 + +.L110: + fcmp.ceq.d $fcc0, BETA, a1 + bcnez $fcc0, .L114 // ALPHA==0 BETA==0 + b .L113 // ALPHA==0 BETA!=0 + .align 3 + +.L111: // ALPHA!=0 BETA!=0 + xvld VX0, X, 0 * SIZE + xvld VX2, Y, 0 * SIZE + xvld VX1, X, 4 * SIZE + xvld VX3, Y, 4 * SIZE + xvfmul.d VX0, VX0, VXA + xvfmul.d VX1, VX1, VXA + xvfmadd.d VX2, VX2, VXB, VX0 + xvfmadd.d VX3, VX3, VXB, VX1 + addi.d I, I, -1 + xvst VX2, Y, 0 * SIZE + xvst VX3, Y, 4 * SIZE + addi.d X, X, 8 * SIZE + addi.d Y, Y, 8 * SIZE + blt $r0, I, .L111 + b .L997 + .align 3 + +.L112: // ALPHA!=0 BETA==0 + xvld VX0, X, 0 * SIZE + xvld VX1, X, 4 * SIZE + xvfmul.d VX0, VX0, VXA + xvfmul.d VX1, VX1, VXA + xvst VX0, Y, 0 * SIZE + xvst VX1, Y, 4 * SIZE + addi.d X, X, 8 * SIZE + addi.d Y, Y, 8 * SIZE + addi.d I, I, -1 + blt $r0, I, .L112 + b .L997 + .align 3 + +.L113: // ALPHA==0 BETA!=0 + xvld VX2, Y, 0 * SIZE + xvld VX3, Y, 4 * SIZE + xvfmul.d VX2, VX2, VXB + xvfmul.d VX3, VX3, VXB + xvst VX2, Y, 0 * SIZE + xvst VX3, Y, 4 * SIZE + addi.d Y, Y, 8 * SIZE + addi.d I, I, -1 + blt $r0, I, .L113 + b .L997 + .align 3 + +.L114: // ALPHA==0 BETA==0 + xvst VXZ, Y, 0 * SIZE + xvst VXZ, Y, 4 * SIZE + addi.d Y, Y, 8 * SIZE + addi.d I, I, -1 + blt $r0, I, .L114 + b .L997 + .align 3 + +.L12: // INCX==1 and INCY!=1 + bge $r0, I, .L997 + move YY, Y + fcmp.ceq.d $fcc0, ALPHA, a1 + bcnez $fcc0, .L120 + fcmp.ceq.d $fcc0, BETA, a1 + bcnez $fcc0, .L122 // ALPHA!=0 BETA==0 + b .L121 // ALPHA!=0 BETA!=0 + .align 3 + +.L120: + fcmp.ceq.d $fcc0, BETA, a1 + bcnez $fcc0, .L124 // ALPHA==0 BETA==0 + b .L123 // ALPHA==0 BETA!=0 + .align 3 + +.L121: // ALPHA!=0 BETA!=0 + xvld VX0, X, 0 * SIZE + ld.d t1, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t2, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t3, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t4, Y, 0 * SIZE + xvinsgr2vr.d VX2, t1, 0 + xvinsgr2vr.d VX2, t2, 1 + xvinsgr2vr.d VX2, t3, 2 + xvinsgr2vr.d VX2, t4, 3 + add.d Y, Y, INCY + xvfmul.d VX0, VX0, VXA + xvld VX1, X, 4 * SIZE + xvfmadd.d VX2, VX2, VXB, VX0 + ld.d t1, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t2, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t3, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t4, Y, 0 * SIZE + add.d Y, Y, INCY + xvinsgr2vr.d VX3, t1, 0 + xvinsgr2vr.d VX3, t2, 1 + xvinsgr2vr.d VX3, t3, 2 + xvinsgr2vr.d VX3, t4, 3 + xvstelm.d VX2, YY, 0, 0 + add.d YY, YY, INCY + xvstelm.d VX2, YY, 0, 1 + add.d YY, YY, INCY + xvstelm.d VX2, YY, 0, 2 + add.d YY, YY, INCY + xvstelm.d VX2, YY, 0, 3 + add.d YY, YY, INCY + xvfmul.d VX1, VX1, VXA + xvfmadd.d VX3, VX3, VXB, VX1 + addi.d I, I, -1 + xvstelm.d VX3, YY, 0, 0 + add.d YY, YY, INCY + xvstelm.d VX3, YY, 0, 1 + add.d YY, YY, INCY + xvstelm.d VX3, YY, 0, 2 + add.d YY, YY, INCY + xvstelm.d VX3, YY, 0, 3 + add.d YY, YY, INCY + addi.d X, X, 8 * SIZE + blt $r0, I, .L121 + b .L997 + .align 3 + +.L122: // ALPHA!=0 BETA==0 + xvld VX0, X, 0 * SIZE + xvld VX1, X, 4 * SIZE + xvfmul.d VX0, VX0, VXA + xvfmul.d VX1, VX1, VXA + xvstelm.d VX0, YY, 0, 0 + add.d YY, YY, INCY + xvstelm.d VX0, YY, 0, 1 + add.d YY, YY, INCY + xvstelm.d VX0, YY, 0, 2 + add.d YY, YY, INCY + xvstelm.d VX0, YY, 0, 3 + add.d YY, YY, INCY + xvstelm.d VX1, YY, 0, 0 + add.d YY, YY, INCY + xvstelm.d VX1, YY, 0, 1 + add.d YY, YY, INCY + xvstelm.d VX1, YY, 0, 2 + add.d YY, YY, INCY + xvstelm.d VX1, YY, 0, 3 + add.d YY, YY, INCY + addi.d X, X, 8 * SIZE + addi.d I, I, -1 + blt $r0, I, .L122 + b .L997 + .align 3 + +.L123: // ALPHA==0 BETA!=0 + ld.d t1, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t2, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t3, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t4, Y, 0 * SIZE + xvinsgr2vr.d VX2, t1, 0 + xvinsgr2vr.d VX2, t2, 1 + xvinsgr2vr.d VX2, t3, 2 + xvinsgr2vr.d VX2, t4, 3 + add.d Y, Y, INCY + xvfmul.d VX2, VX2, VXB + ld.d t1, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t2, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t3, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t4, Y, 0 * SIZE + add.d Y, Y, INCY + xvinsgr2vr.d VX3, t1, 0 + xvinsgr2vr.d VX3, t2, 1 + xvinsgr2vr.d VX3, t3, 2 + xvinsgr2vr.d VX3, t4, 3 + xvstelm.d VX2, YY, 0, 0 + add.d YY, YY, INCY + xvstelm.d VX2, YY, 0, 1 + add.d YY, YY, INCY + xvstelm.d VX2, YY, 0, 2 + add.d YY, YY, INCY + xvstelm.d VX2, YY, 0, 3 + add.d YY, YY, INCY + xvfmul.d VX3, VX3, VXB + addi.d I, I, -1 + xvstelm.d VX3, YY, 0, 0 + add.d YY, YY, INCY + xvstelm.d VX3, YY, 0, 1 + add.d YY, YY, INCY + xvstelm.d VX3, YY, 0, 2 + add.d YY, YY, INCY + xvstelm.d VX3, YY, 0, 3 + add.d YY, YY, INCY + blt $r0, I, .L123 + b .L997 + .align 3 + +.L124: // ALPHA==0 BETA==0 + xvstelm.d VXZ, YY, 0, 0 + add.d YY, YY, INCY + xvstelm.d VXZ, YY, 0, 1 + add.d YY, YY, INCY + xvstelm.d VXZ, YY, 0, 2 + add.d YY, YY, INCY + xvstelm.d VXZ, YY, 0, 3 + add.d YY, YY, INCY + xvstelm.d VXZ, YY, 0, 0 + add.d YY, YY, INCY + xvstelm.d VXZ, YY, 0, 1 + add.d YY, YY, INCY + xvstelm.d VXZ, YY, 0, 2 + add.d YY, YY, INCY + xvstelm.d VXZ, YY, 0, 3 + add.d YY, YY, INCY + addi.d I, I, -1 + blt $r0, I, .L124 + b .L997 + .align 3 + +.L21:// INCX!=1 and INCY==1 + bge $r0, I, .L997 + fcmp.ceq.d $fcc0, ALPHA, a1 + bcnez $fcc0, .L210 + fcmp.ceq.d $fcc0, BETA, a1 + bcnez $fcc0, .L212 // ALPHA!=0 BETA==0 + b .L211 // ALPHA!=0 BETA!=0 + .align 3 + +.L210: + fcmp.ceq.d $fcc0, BETA, a1 + bcnez $fcc0, .L214 // ALPHA==0 BETA==0 + b .L213 // ALPHA==0 BETA!=0 + .align 3 + +.L211: // ALPHA!=0 BETA!=0 + xvld VX2, Y, 0 * SIZE + ld.d t1, X, 0 * SIZE + add.d X, X, INCX + ld.d t2, X, 0 * SIZE + add.d X, X, INCX + ld.d t3, X, 0 * SIZE + add.d X, X, INCX + ld.d t4, X, 0 * SIZE + xvinsgr2vr.d VX0, t1, 0 + xvinsgr2vr.d VX0, t2, 1 + xvinsgr2vr.d VX0, t3, 2 + xvinsgr2vr.d VX0, t4, 3 + add.d X, X, INCX + xvfmul.d VX0, VXA, VX0 + xvfmadd.d VX2, VX2, VXB, VX0 + xvld VX3, Y, 4 * SIZE + xvst VX2, Y, 0 * SIZE + ld.d t1, X, 0 * SIZE + add.d X, X, INCX + ld.d t2, X, 0 * SIZE + add.d X, X, INCX + ld.d t3, X, 0 * SIZE + add.d X, X, INCX + ld.d t4, X, 0 * SIZE + xvinsgr2vr.d VX1, t1, 0 + xvinsgr2vr.d VX1, t2, 1 + xvinsgr2vr.d VX1, t3, 2 + xvinsgr2vr.d VX1, t4, 3 + add.d X, X, INCX + xvfmul.d VX1, VX1, VXA + xvfmadd.d VX3, VX3, VXB, VX1 + addi.d I, I, -1 + xvst VX3, Y, 4 * SIZE + addi.d Y, Y, 8 * SIZE + blt $r0, I, .L211 + b .L997 + .align 3 + +.L212: // ALPHA!=0 BETA==0 + ld.d t1, X, 0 * SIZE + add.d X, X, INCX + ld.d t2, X, 0 * SIZE + add.d X, X, INCX + ld.d t3, X, 0 * SIZE + add.d X, X, INCX + ld.d t4, X, 0 * SIZE + xvinsgr2vr.d VX0, t1, 0 + xvinsgr2vr.d VX0, t2, 1 + xvinsgr2vr.d VX0, t3, 2 + xvinsgr2vr.d VX0, t4, 3 + add.d X, X, INCX + xvfmul.d VX0, VXA, VX0 + ld.d t1, X, 0 * SIZE + add.d X, X, INCX + ld.d t2, X, 0 * SIZE + add.d X, X, INCX + ld.d t3, X, 0 * SIZE + add.d X, X, INCX + ld.d t4, X, 0 * SIZE + add.d X, X, INCX + xvinsgr2vr.d VX1, t1, 0 + xvinsgr2vr.d VX1, t2, 1 + xvinsgr2vr.d VX1, t3, 2 + xvinsgr2vr.d VX1, t4, 3 + xvst VX0, Y, 0 * SIZE + xvfmul.d VX1, VX1, VXA + addi.d I, I, -1 + xvst VX1, Y, 4 * SIZE + addi.d Y, Y, 8 * SIZE + blt $r0, I, .L212 + b .L997 + .align 3 + +.L213: // ALPHA==0 BETA!=0 + xvld VX2, Y, 0 * SIZE + xvld VX3, Y, 4 * SIZE + xvfmul.d VX2, VX2, VXB + xvfmul.d VX3, VX3, VXB + addi.d I, I, -1 + xvst VX2, Y, 0 * SIZE + xvst VX3, Y, 4 * SIZE + addi.d Y, Y, 8 * SIZE + blt $r0, I, .L213 + b .L997 + .align 3 + +.L214: // ALPHA==0 BETA==0 + xvst VXZ, Y, 0 * SIZE + xvst VXZ, Y, 4 * SIZE + addi.d Y, Y, 8 * SIZE + addi.d I, I, -1 + blt $r0, I, .L214 + b .L997 + .align 3 + +.L22: + bge $r0, I, .L997 + move YY, Y + fcmp.ceq.d $fcc0, ALPHA, a1 + bcnez $fcc0, .L220 + fcmp.ceq.d $fcc0, BETA, a1 + bcnez $fcc0, .L222 // ALPHA!=0 BETA==0 + b .L221 // ALPHA!=0 BETA!=0 + .align 3 + +.L220: + fcmp.ceq.d $fcc0, BETA, a1 + bcnez $fcc0, .L224 // ALPHA==0 BETA==0 + b .L223 // ALPHA==0 BETA!=0 + .align 3 + +.L221: // ALPHA!=0 BETA!=0 + ld.d t1, X, 0 * SIZE + add.d X, X, INCX + ld.d t2, X, 0 * SIZE + add.d X, X, INCX + ld.d t3, X, 0 * SIZE + add.d X, X, INCX + ld.d t4, X, 0 * SIZE + add.d X, X, INCX + xvinsgr2vr.d VX0, t1, 0 + xvinsgr2vr.d VX0, t2, 1 + xvinsgr2vr.d VX0, t3, 2 + xvinsgr2vr.d VX0, t4, 3 + ld.d t1, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t2, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t3, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t4, Y, 0 * SIZE + xvinsgr2vr.d VX2, t1, 0 + xvinsgr2vr.d VX2, t2, 1 + xvinsgr2vr.d VX2, t3, 2 + xvinsgr2vr.d VX2, t4, 3 + add.d Y, Y, INCY + xvfmul.d VX0, VX0, VXA + ld.d t1, X, 0 * SIZE + add.d X, X, INCX + xvfmadd.d VX2, VX2, VXB, VX0 + ld.d t2, X, 0 * SIZE + add.d X, X, INCX + ld.d t3, X, 0 * SIZE + add.d X, X, INCX + ld.d t4, X, 0 * SIZE + add.d X, X, INCX + xvinsgr2vr.d VX1, t1, 0 + xvinsgr2vr.d VX1, t2, 1 + xvinsgr2vr.d VX1, t3, 2 + xvinsgr2vr.d VX1, t4, 3 + xvstelm.d VX2, YY, 0, 0 + add.d YY, YY, INCY + xvstelm.d VX2, YY, 0, 1 + add.d YY, YY, INCY + xvstelm.d VX2, YY, 0, 2 + add.d YY, YY, INCY + xvstelm.d VX2, YY, 0, 3 + add.d YY, YY, INCY + ld.d t1, Y, 0 * SIZE + xvinsgr2vr.d VX3, t1, 0 + add.d Y, Y, INCY + ld.d t2, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t3, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t4, Y, 0 * SIZE + xvinsgr2vr.d VX3, t2, 1 + xvinsgr2vr.d VX3, t3, 2 + xvinsgr2vr.d VX3, t4, 3 + add.d Y, Y, INCY + xvfmul.d VX1, VX1, VXA + xvfmadd.d VX3, VX3, VXB, VX1 + addi.d I, I, -1 + xvstelm.d VX3, YY, 0, 0 + add.d YY, YY, INCY + xvstelm.d VX3, YY, 0, 1 + add.d YY, YY, INCY + xvstelm.d VX3, YY, 0, 2 + add.d YY, YY, INCY + xvstelm.d VX3, YY, 0, 3 + add.d YY, YY, INCY + blt $r0, I, .L221 + b .L997 + .align 3 + +.L222: // ALPHA!=0 BETA==0 + ld.d t1, X, 0 * SIZE + add.d X, X, INCX + ld.d t2, X, 0 * SIZE + add.d X, X, INCX + ld.d t3, X, 0 * SIZE + add.d X, X, INCX + ld.d t4, X, 0 * SIZE + xvinsgr2vr.d VX0, t1, 0 + xvinsgr2vr.d VX0, t2, 1 + xvinsgr2vr.d VX0, t3, 2 + xvinsgr2vr.d VX0, t4, 3 + add.d X, X, INCX + xvfmul.d VX0, VX0, VXA + ld.d t1, X, 0 * SIZE + add.d X, X, INCX + ld.d t2, X, 0 * SIZE + add.d X, X, INCX + ld.d t3, X, 0 * SIZE + add.d X, X, INCX + ld.d t4, X, 0 * SIZE + add.d X, X, INCX + xvinsgr2vr.d VX1, t1, 0 + xvinsgr2vr.d VX1, t2, 1 + xvinsgr2vr.d VX1, t3, 2 + xvinsgr2vr.d VX1, t4, 3 + xvstelm.d VX0, YY, 0, 0 + add.d YY, YY, INCY + xvstelm.d VX0, YY, 0, 1 + add.d YY, YY, INCY + xvstelm.d VX0, YY, 0, 2 + add.d YY, YY, INCY + xvstelm.d VX0, YY, 0, 3 + add.d YY, YY, INCY + xvfmul.d VX1, VX1, VXA + addi.d I, I, -1 + xvstelm.d VX1, YY, 0, 0 + add.d YY, YY, INCY + xvstelm.d VX1, YY, 0, 1 + add.d YY, YY, INCY + xvstelm.d VX1, YY, 0, 2 + add.d YY, YY, INCY + xvstelm.d VX1, YY, 0, 3 + add.d YY, YY, INCY + blt $r0, I, .L222 + b .L997 + .align 3 + +.L223: // ALPHA==0 BETA!=0 + ld.d t1, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t2, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t3, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t4, Y, 0 * SIZE + xvinsgr2vr.d VX2, t1, 0 + xvinsgr2vr.d VX2, t2, 1 + xvinsgr2vr.d VX2, t3, 2 + xvinsgr2vr.d VX2, t4, 3 + add.d Y, Y, INCY + xvfmul.d VX2, VX2, VXB + ld.d t1, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t2, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t3, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t4, Y, 0 * SIZE + add.d Y, Y, INCY + xvinsgr2vr.d VX3, t1, 0 + xvinsgr2vr.d VX3, t2, 1 + xvinsgr2vr.d VX3, t3, 2 + xvinsgr2vr.d VX3, t4, 3 + xvstelm.d VX2, YY, 0, 0 + add.d YY, YY, INCY + xvstelm.d VX2, YY, 0, 1 + add.d YY, YY, INCY + xvstelm.d VX2, YY, 0, 2 + add.d YY, YY, INCY + xvstelm.d VX2, YY, 0, 3 + add.d YY, YY, INCY + xvfmul.d VX3, VX3, VXB + addi.d I, I, -1 + xvstelm.d VX3, YY, 0, 0 + add.d YY, YY, INCY + xvstelm.d VX3, YY, 0, 1 + add.d YY, YY, INCY + xvstelm.d VX3, YY, 0, 2 + add.d YY, YY, INCY + xvstelm.d VX3, YY, 0, 3 + add.d YY, YY, INCY + blt $r0, I, .L223 + b .L997 + .align 3 + +.L224: // ALPHA==0 BETA==0 + xvstelm.d VXZ, YY, 0, 0 + add.d YY, YY, INCY + xvstelm.d VXZ, YY, 0, 1 + add.d YY, YY, INCY + xvstelm.d VXZ, YY, 0, 2 + add.d YY, YY, INCY + xvstelm.d VXZ, YY, 0, 3 + add.d YY, YY, INCY + xvstelm.d VXZ, YY, 0, 0 + add.d YY, YY, INCY + xvstelm.d VXZ, YY, 0, 1 + add.d YY, YY, INCY + xvstelm.d VXZ, YY, 0, 2 + add.d YY, YY, INCY + xvstelm.d VXZ, YY, 0, 3 + add.d YY, YY, INCY + addi.d I, I, -1 + blt $r0, I, .L224 + b .L997 + .align 3 + +.L997: + andi I, N, 7 + bge $r0, I, .L999 + .align 3 + +.L998: + fld.d $f12, X, 0 * SIZE + fld.d $f13, Y, 0 * SIZE + addi.d I, I, -1 + fmul.d $f12, $f12, ALPHA + fmadd.d $f13, $f13, BETA, $f12 + fst.d $f13, Y, 0 * SIZE + add.d X, X, INCX + add.d Y, Y, INCY + blt $r0, I, .L998 + .align 3 + +.L999: + move $r4, $r12 + jirl $r0, $r1, 0x0 + .align 3 + + EPILOGUE diff --git a/kernel/loongarch64/daxpby_lsx.S b/kernel/loongarch64/daxpby_lsx.S new file mode 100644 index 000000000..9aafbaf2a --- /dev/null +++ b/kernel/loongarch64/daxpby_lsx.S @@ -0,0 +1,693 @@ +#define ASSEMBLER + +#include "common.h" +#define N $r4 +#define ALPHA $f0 +#define X $r5 +#define INCX $r6 +#define BETA $f1 +#define Y $r7 +#define INCY $r8 + +#define I $r12 +#define TEMP $r13 +#define t1 $r14 +#define t2 $r16 +#define t3 $r15 +#define t4 $r17 +#define XX $r18 +#define YY $r19 +#define a1 $f12 +#define a2 $f13 +#define VX0 $vr8 +#define VX1 $vr20 +#define VX2 $vr21 +#define VX3 $vr22 +#define VXA $vr23 +#define VXB $vr9 +#define VXZ $vr19 + + PROLOGUE + + bge $r0, N, .L999 + li.d TEMP, 1 + movgr2fr.d a1, $r0 + ffint.d.l a1, a1 + slli.d TEMP, TEMP, BASE_SHIFT + slli.d INCX, INCX, BASE_SHIFT + slli.d INCY, INCY, BASE_SHIFT + movfr2gr.d t1, ALPHA + vreplgr2vr.d VXA, t1 + movfr2gr.d t2, BETA + vreplgr2vr.d VXB, t2 + movfr2gr.d t3, a1 + vreplgr2vr.d VXZ, t3 + srai.d I, N, 3 + bne INCX, TEMP, .L20 + bne INCY, TEMP, .L12 // INCX==1 and INCY!=1 + b .L11 // INCX==1 and INCY==1 +.L20: + bne INCY, TEMP, .L22 // INCX!=1 and INCY!=1 + b .L21 // INCX!=1 and INCY==1 + +.L11: + bge $r0, I, .L997 + fcmp.ceq.d $fcc0, ALPHA, a1 + bcnez $fcc0, .L110 + fcmp.ceq.d $fcc0, BETA, a1 + bcnez $fcc0, .L112 // ALPHA!=0 BETA==0 + b .L111 // ALPHA!=0 BETA!=0 + .align 3 + +.L110: + fcmp.ceq.d $fcc0, BETA, a1 + bcnez $fcc0, .L114 // ALPHA==0 BETA==0 + b .L113 // ALPHA==0 BETA!=0 + .align 3 + +.L111: // ALPHA!=0 BETA!=0 + vld VX0, X, 0 * SIZE + vld VX2, Y, 0 * SIZE + vld VX1, X, 2 * SIZE + vld VX3, Y, 2 * SIZE + vfmul.d VX0, VX0, VXA + vfmul.d VX1, VX1, VXA + vfmadd.d VX2, VX2, VXB, VX0 + vfmadd.d VX3, VX3, VXB, VX1 + vst VX2, Y, 0 * SIZE + vst VX3, Y, 2 * SIZE + vld VX0, X, 4 * SIZE + vld VX2, Y, 4 * SIZE + vld VX1, X, 6 * SIZE + vld VX3, Y, 6 * SIZE + vfmul.d VX0, VX0, VXA + vfmul.d VX1, VX1, VXA + vfmadd.d VX2, VX2, VXB, VX0 + vfmadd.d VX3, VX3, VXB, VX1 + vst VX2, Y, 4 * SIZE + vst VX3, Y, 6 * SIZE + addi.d X, X, 8 * SIZE + addi.d Y, Y, 8 * SIZE + addi.d I, I, -1 + blt $r0, I, .L111 + b .L997 + .align 3 + +.L112: // ALPHA!=0 BETA==0 + vld VX0, X, 0 * SIZE + vld VX1, X, 2 * SIZE + vfmul.d VX0, VX0, VXA + vfmul.d VX1, VX1, VXA + vst VX0, Y, 0 * SIZE + vst VX1, Y, 2 * SIZE + vld VX2, X, 4 * SIZE + vld VX3, X, 6 * SIZE + vfmul.d VX2, VX2, VXA + vfmul.d VX3, VX3, VXA + vst VX2, Y, 4 * SIZE + vst VX3, Y, 6 * SIZE + addi.d X, X, 8 * SIZE + addi.d Y, Y, 8 * SIZE + addi.d I, I, -1 + blt $r0, I, .L112 + b .L997 + .align 3 + +.L113: // ALPHA==0 BETA!=0\ + vld VX0, Y, 0 * SIZE + vld VX1, Y, 2 * SIZE + vfmul.d VX0, VX0, VXB + vfmul.d VX1, VX1, VXB + vst VX0, Y, 0 * SIZE + vst VX1, Y, 2 * SIZE + vld VX2, Y, 4 * SIZE + vld VX3, Y, 6 * SIZE + vfmul.d VX2, VX2, VXB + vfmul.d VX3, VX3, VXB + vst VX2, Y, 4 * SIZE + vst VX3, Y, 6 * SIZE + addi.d Y, Y, 8 * SIZE + addi.d I, I, -1 + blt $r0, I, .L113 + b .L997 + .align 3 + +.L114: // ALPHA==0 BETA==0 + vst VXZ, Y, 0 * SIZE + vst VXZ, Y, 2 * SIZE + vst VXZ, Y, 4 * SIZE + vst VXZ, Y, 6 * SIZE + addi.d Y, Y, 8 * SIZE + addi.d I, I, -1 + blt $r0, I, .L114 + b .L997 + .align 3 + +.L12: // INCX==1 and INCY!=1 + bge $r0, I, .L997 + move YY, Y + fcmp.ceq.d $fcc0, ALPHA, a1 + bcnez $fcc0, .L120 + fcmp.ceq.d $fcc0, BETA, a1 + bcnez $fcc0, .L122 // ALPHA!=0 BETA==0 + b .L121 // ALPHA!=0 BETA!=0 + .align 3 + +.L120: + fcmp.ceq.d $fcc0, BETA, a1 + bcnez $fcc0, .L124 // ALPHA==0 BETA==0 + b .L123 // ALPHA==0 BETA!=0 + .align 3 + +.L121: // ALPHA!=0 BETA!=0 + vld VX0, X, 0 * SIZE + ld.d t1, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t2, Y, 0 * SIZE + add.d Y, Y, INCY + vinsgr2vr.d VX2, t1, 0 + vinsgr2vr.d VX2, t2, 1 + vfmul.d VX0, VX0, VXA + vld VX1, X, 2 * SIZE + vfmadd.d VX2, VX2, VXB, VX0 + ld.d t3, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t4, Y, 0 * SIZE + add.d Y, Y, INCY + vinsgr2vr.d VX3, t3, 0 + vinsgr2vr.d VX3, t4, 1 + vstelm.d VX2, YY, 0, 0 + add.d YY, YY, INCY + vstelm.d VX2, YY, 0, 1 + add.d YY, YY, INCY + vfmul.d VX1, VX1, VXA + vld VX0, X, 4 * SIZE + vfmadd.d VX3, VX3, VXB, VX1 + ld.d t1, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t2, Y, 0 * SIZE + add.d Y, Y, INCY + vinsgr2vr.d VX2, t1, 0 + vinsgr2vr.d VX2, t2, 1 + vstelm.d VX3, YY, 0, 0 + add.d YY, YY, INCY + vstelm.d VX3, YY, 0, 1 + add.d YY, YY, INCY + vfmul.d VX0, VX0, VXA + vld VX1, X, 6 * SIZE + vfmadd.d VX2, VX2, VXB, VX0 + ld.d t3, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t4, Y, 0 * SIZE + add.d Y, Y, INCY + vinsgr2vr.d VX3, t3, 0 + vinsgr2vr.d VX3, t4, 1 + vstelm.d VX2, YY, 0, 0 + add.d YY, YY, INCY + vstelm.d VX2, YY, 0, 1 + add.d YY, YY, INCY + vfmul.d VX1, VX1, VXA + vfmadd.d VX3, VX3, VXB, VX1 + addi.d I, I, -1 + vstelm.d VX3, YY, 0, 0 + add.d YY, YY, INCY + vstelm.d VX3, YY, 0, 1 + add.d YY, YY, INCY + addi.d X, X, 8 * SIZE + blt $r0, I, .L121 + b .L997 + .align 3 + +.L122: // ALPHA!=0 BETA==0 + vld VX0, X, 0 * SIZE + vld VX1, X, 2 * SIZE + vfmul.d VX0, VX0, VXA + vfmul.d VX1, VX1, VXA + vstelm.d VX0, YY, 0, 0 + add.d YY, YY, INCY + vstelm.d VX0, YY, 0, 1 + add.d YY, YY, INCY + vstelm.d VX1, YY, 0, 0 + add.d YY, YY, INCY + vstelm.d VX1, YY, 0, 1 + add.d YY, YY, INCY + vld VX0, X, 4 * SIZE + vld VX1, X, 6 * SIZE + vfmul.d VX0, VX0, VXA + vfmul.d VX1, VX1, VXA + vstelm.d VX0, YY, 0, 0 + add.d YY, YY, INCY + vstelm.d VX0, YY, 0, 1 + add.d YY, YY, INCY + vstelm.d VX1, YY, 0, 0 + add.d YY, YY, INCY + vstelm.d VX1, YY, 0, 1 + add.d YY, YY, INCY + addi.d X, X, 8 * SIZE + addi.d I, I, -1 + blt $r0, I, .L122 + b .L997 + .align 3 + +.L123: // ALPHA==0 BETA!=0 + ld.d t1, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t2, Y, 0 * SIZE + vinsgr2vr.d VX2, t1, 0 + vinsgr2vr.d VX2, t2, 1 + add.d Y, Y, INCY + vfmul.d VX2, VX2, VXB + ld.d t3, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t4, Y, 0 * SIZE + add.d Y, Y, INCY + vinsgr2vr.d VX3, t3, 0 + vinsgr2vr.d VX3, t4, 1 + vstelm.d VX2, YY, 0, 0 + add.d YY, YY, INCY + vstelm.d VX2, YY, 0, 1 + add.d YY, YY, INCY + vfmul.d VX3, VX3, VXB + ld.d t1, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t2, Y, 0 * SIZE + add.d Y, Y, INCY + vinsgr2vr.d VX2, t1, 0 + vinsgr2vr.d VX2, t2, 1 + vstelm.d VX3, YY, 0, 0 + add.d YY, YY, INCY + vstelm.d VX3, YY, 0, 1 + add.d YY, YY, INCY + vfmul.d VX2, VX2, VXB + ld.d t3, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t4, Y, 0 * SIZE + add.d Y, Y, INCY + vinsgr2vr.d VX3, t3, 0 + vinsgr2vr.d VX3, t4, 1 + vstelm.d VX2, YY, 0, 0 + add.d YY, YY, INCY + vstelm.d VX2, YY, 0, 1 + add.d YY, YY, INCY + vfmul.d VX3, VX3, VXB + addi.d I, I, -1 + vstelm.d VX3, YY, 0, 0 + add.d YY, YY, INCY + vstelm.d VX3, YY, 0, 1 + add.d YY, YY, INCY + blt $r0, I, .L123 + b .L997 + .align 3 + +.L124: // ALPHA==0 BETA==0 + vstelm.d VXZ, YY, 0, 0 + add.d YY, YY, INCY + vstelm.d VXZ, YY, 0, 1 + add.d YY, YY, INCY + vstelm.d VXZ, YY, 0, 0 + add.d YY, YY, INCY + vstelm.d VXZ, YY, 0, 1 + add.d YY, YY, INCY + vstelm.d VXZ, YY, 0, 0 + add.d YY, YY, INCY + vstelm.d VXZ, YY, 0, 1 + add.d YY, YY, INCY + vstelm.d VXZ, YY, 0, 0 + add.d YY, YY, INCY + vstelm.d VXZ, YY, 0, 1 + add.d YY, YY, INCY + addi.d I, I, -1 + blt $r0, I, .L124 + b .L997 + .align 3 + +.L21:// INCX!=1 and INCY==1 + bge $r0, I, .L997 + fcmp.ceq.d $fcc0, ALPHA, a1 + bcnez $fcc0, .L210 + fcmp.ceq.d $fcc0, BETA, a1 + bcnez $fcc0, .L212 // ALPHA!=0 BETA==0 + b .L211 // ALPHA!=0 BETA!=0 + .align 3 + +.L210: + fcmp.ceq.d $fcc0, BETA, a1 + bcnez $fcc0, .L214 // ALPHA==0 BETA==0 + b .L213 // ALPHA==0 BETA!=0 + .align 3 + +.L211: // ALPHA!=0 BETA!=0 + vld VX2, Y, 0 * SIZE + ld.d t1, X, 0 * SIZE + add.d X, X, INCX + ld.d t2, X, 0 * SIZE + vinsgr2vr.d VX0, t1, 0 + vinsgr2vr.d VX0, t2, 1 + add.d X, X, INCX + vfmul.d VX0, VXA, VX0 + vld VX3, Y, 2 * SIZE + vfmadd.d VX2, VX2, VXB, VX0 + ld.d t3, X, 0 * SIZE + add.d X, X, INCX + ld.d t4, X, 0 * SIZE + add.d X, X, INCX + vinsgr2vr.d VX1, t3, 0 + vinsgr2vr.d VX1, t4, 1 + vst VX2, Y, 0 * SIZE + vfmul.d VX1, VXA, VX1 + vld VX2, Y, 4 * SIZE + vfmadd.d VX3, VX3, VXB, VX1 + ld.d t1, X, 0 * SIZE + add.d X, X, INCX + ld.d t2, X, 0 * SIZE + add.d X, X, INCX + vinsgr2vr.d VX0, t1, 0 + vinsgr2vr.d VX0, t2, 1 + vst VX3, Y, 2 * SIZE + vfmul.d VX0, VX0, VXA + vld VX3, Y, 6 * SIZE + vfmadd.d VX2, VX2, VXB, VX0 + ld.d t3, X, 0 * SIZE + add.d X, X, INCX + ld.d t4, X, 0 * SIZE + add.d X, X, INCX + vinsgr2vr.d VX1, t3, 0 + vinsgr2vr.d VX1, t4, 1 + vst VX2, Y, 4 * SIZE + vfmul.d VX1, VX1, VXA + vfmadd.d VX3, VX3, VXB, VX1 + addi.d I, I, -1 + vst VX3, Y, 6 * SIZE + addi.d Y, Y, 8 * SIZE + blt $r0, I, .L211 + b .L997 + .align 3 + +.L212: // ALPHA!=0 BETA==0 + ld.d t1, X, 0 * SIZE + add.d X, X, INCX + ld.d t2, X, 0 * SIZE + vinsgr2vr.d VX0, t1, 0 + vinsgr2vr.d VX0, t2, 1 + add.d X, X, INCX + vfmul.d VX0, VXA, VX0 + ld.d t3, X, 0 * SIZE + add.d X, X, INCX + ld.d t4, X, 0 * SIZE + add.d X, X, INCX + vinsgr2vr.d VX1, t3, 0 + vinsgr2vr.d VX1, t4, 1 + vst VX0, Y, 0 * SIZE + vfmul.d VX1, VXA, VX1 + ld.d t1, X, 0 * SIZE + add.d X, X, INCX + ld.d t2, X, 0 * SIZE + add.d X, X, INCX + vinsgr2vr.d VX0, t1, 0 + vinsgr2vr.d VX0, t2, 1 + vst VX1, Y, 2 * SIZE + vfmul.d VX0, VX0, VXA + ld.d t3, X, 0 * SIZE + add.d X, X, INCX + ld.d t4, X, 0 * SIZE + add.d X, X, INCX + vinsgr2vr.d VX1, t3, 0 + vinsgr2vr.d VX1, t4, 1 + vst VX0, Y, 4 * SIZE + vfmul.d VX1, VX1, VXA + addi.d I, I, -1 + vst VX1, Y, 6 * SIZE + addi.d Y, Y, 8 * SIZE + blt $r0, I, .L212 + b .L997 + .align 3 + +.L213: // ALPHA==0 BETA!=0 + vld VX2, Y, 0 * SIZE + vld VX3, Y, 2 * SIZE + vfmul.d VX2, VX2, VXB + vfmul.d VX3, VX3, VXB + vst VX2, Y, 0 * SIZE + vst VX3, Y, 2 * SIZE + vld VX2, Y, 4 * SIZE + vld VX3, Y, 6 * SIZE + vfmul.d VX2, VX2, VXB + vfmul.d VX3, VX3, VXB + addi.d I, I, -1 + vst VX2, Y, 4 * SIZE + vst VX3, Y, 6 * SIZE + addi.d Y, Y, 8 * SIZE + blt $r0, I, .L213 + b .L997 + .align 3 + +.L214: // ALPHA==0 BETA==0 + vst VXZ, Y, 0 * SIZE + vst VXZ, Y, 2 * SIZE + vst VXZ, Y, 4 * SIZE + vst VXZ, Y, 6 * SIZE + addi.d Y, Y, 8 * SIZE + addi.d I, I, -1 + blt $r0, I, .L214 + b .L997 + .align 3 + +.L22: + bge $r0, I, .L997 + move YY, Y + fcmp.ceq.d $fcc0, ALPHA, a1 + bcnez $fcc0, .L220 + fcmp.ceq.d $fcc0, BETA, a1 + bcnez $fcc0, .L222 // ALPHA!=0 BETA==0 + b .L221 // ALPHA!=0 BETA!=0 + .align 3 + +.L220: + fcmp.ceq.d $fcc0, BETA, a1 + bcnez $fcc0, .L224 // ALPHA==0 BETA==0 + b .L223 // ALPHA==0 BETA!=0 + .align 3 + +.L221: // ALPHA!=0 BETA!=0 + ld.d t1, X, 0 * SIZE + add.d X, X, INCX + ld.d t2, X, 0 * SIZE + add.d X, X, INCX + vinsgr2vr.d VX0, t1, 0 + vinsgr2vr.d VX0, t2, 1 + ld.d t3, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t4, Y, 0 * SIZE + vinsgr2vr.d VX2, t3, 0 + vinsgr2vr.d VX2, t4, 1 + add.d Y, Y, INCY + vfmul.d VX0, VX0, VXA + vfmadd.d VX2, VX2, VXB, VX0 + ld.d t1, X, 0 * SIZE + add.d X, X, INCX + ld.d t2, X, 0 * SIZE + add.d X, X, INCX + vinsgr2vr.d VX1, t1, 0 + vinsgr2vr.d VX1, t2, 1 + vstelm.d VX2, YY, 0, 0 + add.d YY, YY, INCY + vstelm.d VX2, YY, 0, 1 + add.d YY, YY, INCY + ld.d t3, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t4, Y, 0 * SIZE + vinsgr2vr.d VX3, t3, 0 + vinsgr2vr.d VX3, t4, 1 + add.d Y, Y, INCY + vfmul.d VX1, VX1, VXA + vfmadd.d VX3, VX3, VXB, VX1 + ld.d t1, X, 0 * SIZE + add.d X, X, INCX + ld.d t2, X, 0 * SIZE + add.d X, X, INCX + vinsgr2vr.d VX0, t1, 0 + vinsgr2vr.d VX0, t2, 1 + vstelm.d VX3, YY, 0, 0 + add.d YY, YY, INCY + vstelm.d VX3, YY, 0, 1 + add.d YY, YY, INCY + ld.d t3, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t4, Y, 0 * SIZE + vinsgr2vr.d VX2, t3, 0 + vinsgr2vr.d VX2, t4, 1 + add.d Y, Y, INCY + vfmul.d VX0, VX0, VXA + vfmadd.d VX2, VX2, VXB, VX0 + ld.d t3, X, 0 * SIZE + add.d X, X, INCX + ld.d t4, X, 0 * SIZE + add.d X, X, INCX + vinsgr2vr.d VX1, t3, 0 + vinsgr2vr.d VX1, t4, 1 + vstelm.d VX2, YY, 0, 0 + add.d YY, YY, INCY + vstelm.d VX2, YY, 0, 1 + add.d YY, YY, INCY + ld.d t1, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t2, Y, 0 * SIZE + vinsgr2vr.d VX3, t1, 0 + vinsgr2vr.d VX3, t2, 1 + add.d Y, Y, INCY + vfmul.d VX1, VX1, VXA + vfmadd.d VX3, VX3, VXB, VX1 + addi.d I, I, -1 + vstelm.d VX3, YY, 0, 0 + add.d YY, YY, INCY + vstelm.d VX3, YY, 0, 1 + add.d YY, YY, INCY + blt $r0, I, .L221 + b .L997 + .align 3 + +.L222: // ALPHA!=0 BETA==0 + ld.d t1, X, 0 * SIZE + add.d X, X, INCX + ld.d t2, X, 0 * SIZE + vinsgr2vr.d VX0, t1, 0 + vinsgr2vr.d VX0, t2, 1 + add.d X, X, INCX + vfmul.d VX0, VX0, VXA + ld.d t3, X, 0 * SIZE + add.d X, X, INCX + ld.d t4, X, 0 * SIZE + add.d X, X, INCX + vinsgr2vr.d VX1, t3, 0 + vinsgr2vr.d VX1, t4, 1 + vstelm.d VX0, YY, 0, 0 + add.d YY, YY, INCY + vstelm.d VX0, YY, 0, 1 + add.d YY, YY, INCY + vfmul.d VX1, VX1, VXA + ld.d t1, X, 0 * SIZE + add.d X, X, INCX + ld.d t2, X, 0 * SIZE + add.d X, X, INCX + vinsgr2vr.d VX0, t1, 0 + vinsgr2vr.d VX0, t2, 1 + vstelm.d VX1, YY, 0, 0 + add.d YY, YY, INCY + vstelm.d VX1, YY, 0, 1 + add.d YY, YY, INCY + vfmul.d VX0, VX0, VXA + ld.d t3, X, 0 * SIZE + add.d X, X, INCX + ld.d t4, X, 0 * SIZE + add.d X, X, INCX + vinsgr2vr.d VX1, t3, 0 + vinsgr2vr.d VX1, t4, 1 + vstelm.d VX0, YY, 0, 0 + add.d YY, YY, INCY + vstelm.d VX0, YY, 0, 1 + add.d YY, YY, INCY + vfmul.d VX1, VX1, VXA + addi.d I, I, -1 + vstelm.d VX1, YY, 0, 0 + add.d YY, YY, INCY + vstelm.d VX1, YY, 0, 1 + add.d YY, YY, INCY + blt $r0, I, .L222 + b .L997 + .align 3 + +.L223: // ALPHA==0 BETA!=0 + ld.d t1, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t2, Y, 0 * SIZE + vinsgr2vr.d VX2, t1, 0 + vinsgr2vr.d VX2, t2, 1 + add.d Y, Y, INCY + vfmul.d VX2, VX2, VXB + ld.d t3, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t4, Y, 0 * SIZE + add.d Y, Y, INCY + vinsgr2vr.d VX3, t3, 0 + vinsgr2vr.d VX3, t4, 1 + vstelm.d VX2, YY, 0, 0 + add.d YY, YY, INCY + vstelm.d VX2, YY, 0, 1 + add.d YY, YY, INCY + vfmul.d VX3, VX3, VXB + ld.d t1, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t2, Y, 0 * SIZE + add.d Y, Y, INCY + vinsgr2vr.d VX2, t1, 0 + vinsgr2vr.d VX2, t2, 1 + vstelm.d VX3, YY, 0, 0 + add.d YY, YY, INCY + vstelm.d VX3, YY, 0, 1 + add.d YY, YY, INCY + vfmul.d VX2, VX2, VXB + ld.d t3, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t4, Y, 0 * SIZE + add.d Y, Y, INCY + vinsgr2vr.d VX3, t3, 0 + vinsgr2vr.d VX3, t4, 1 + vstelm.d VX2, YY, 0, 0 + add.d YY, YY, INCY + vstelm.d VX2, YY, 0, 1 + add.d YY, YY, INCY + vfmul.d VX3, VX3, VXB + addi.d I, I, -1 + vstelm.d VX3, YY, 0, 0 + add.d YY, YY, INCY + vstelm.d VX3, YY, 0, 1 + add.d YY, YY, INCY + blt $r0, I, .L223 + b .L997 + .align 3 + +.L224: // ALPHA==0 BETA==0 + vstelm.d VXZ, YY, 0, 0 + add.d YY, YY, INCY + vstelm.d VXZ, YY, 0, 1 + add.d YY, YY, INCY + vstelm.d VXZ, YY, 0, 0 + add.d YY, YY, INCY + vstelm.d VXZ, YY, 0, 1 + add.d YY, YY, INCY + vstelm.d VXZ, YY, 0, 0 + add.d YY, YY, INCY + vstelm.d VXZ, YY, 0, 1 + add.d YY, YY, INCY + vstelm.d VXZ, YY, 0, 0 + add.d YY, YY, INCY + vstelm.d VXZ, YY, 0, 1 + add.d YY, YY, INCY + addi.d I, I, -1 + blt $r0, I, .L224 + b .L997 + .align 3 + +.L997: + andi I, N, 7 + bge $r0, I, .L999 + .align 3 + +.L998: + fld.d $f12, X, 0 * SIZE + fld.d $f13, Y, 0 * SIZE + addi.d I, I, -1 + fmul.d $f12, $f12, ALPHA + fmadd.d $f13, $f13, BETA, $f12 + fst.d $f13, Y, 0 * SIZE + add.d X, X, INCX + add.d Y, Y, INCY + blt $r0, I, .L998 + .align 3 + +.L999: + move $r4, $r12 + jirl $r0, $r1, 0x0 + .align 3 + + EPILOGUE diff --git a/kernel/loongarch64/daxpy_lasx.S b/kernel/loongarch64/daxpy_lasx.S new file mode 100644 index 000000000..bafd871ab --- /dev/null +++ b/kernel/loongarch64/daxpy_lasx.S @@ -0,0 +1,338 @@ +#define ASSEMBLER + +#include "common.h" +#define N $r4 +#define XX $r5 +#define YY $r6 +#define ALPHA $f0 +#define X $r7 +#define INCX $r8 +#define Y $r9 +#define INCY $r10 + +#define I $r12 +#define TEMP $r13 +#define t1 $r14 +#define t2 $r16 +#define t3 $r15 +#define t4 $r17 +#define a1 $f12 +#define a2 $f13 +#define a3 $f14 +#define a4 $f15 +#define b1 $f16 +#define b2 $f17 +#define b3 $f18 +#define b4 $f19 +#define VX0 $xr8 +#define VX1 $xr20 +#define VX2 $xr21 +#define VX3 $xr22 +#define VXA $xr23 + + PROLOGUE + + bge $r0, N, .L999 + li.d TEMP, 1 + movgr2fr.d a1, $r0 + ffint.d.l a1, a1 + movgr2fr.d a2, TEMP + ffint.d.l a2, a2 + fcmp.ceq.d $fcc0, ALPHA, a1 + bcnez $fcc0, .L999 + slli.d TEMP, TEMP, BASE_SHIFT + slli.d INCX, INCX, BASE_SHIFT + slli.d INCY, INCY, BASE_SHIFT + movfr2gr.d t1, ALPHA + xvreplgr2vr.d VXA, t1 + + srai.d I, N, 3 + bne INCX, TEMP, .L20 + bne INCY, TEMP, .L12 // INCX==1 and INCY!=1 + b .L11 // INCX==1 and INCY==1 +.L20: + bne INCY, TEMP, .L22 // INCX!=1 and INCY!=1 + b .L21 // INCX!=1 and INCY==1 + +.L11: + bge $r0, I, .L113 + fcmp.ceq.d $fcc0, ALPHA, a2 + bceqz $fcc0, .L112 + .align 3 + +.L111: + xvld VX0, X, 0 * SIZE + xvld VX2, Y, 0 * SIZE + xvld VX1, X, 4 * SIZE + xvld VX3, Y, 4 * SIZE + xvfadd.d VX2, VX0, VX2 + xvfadd.d VX3, VX1, VX3 + addi.d I, I, -1 + xvst VX2, Y, 0 * SIZE + xvst VX3, Y, 4 * SIZE + addi.d X, X, 8 * SIZE + addi.d Y, Y, 8 * SIZE + blt $r0, I, .L111 + b .L113 + .align 3 + +.L112: + xvld VX0, X, 0 * SIZE + xvld VX2, Y, 0 * SIZE + xvld VX1, X, 4 * SIZE + xvld VX3, Y, 4 * SIZE + xvfmadd.d VX2, VX0, VXA, VX2 + xvfmadd.d VX3, VX1, VXA, VX3 + addi.d I, I, -1 + xvst VX2, Y, 0 * SIZE + xvst VX3, Y, 4 * SIZE + addi.d X, X, 8 * SIZE + addi.d Y, Y, 8 * SIZE + blt $r0, I, .L112 + .align 3 + +.L113: + andi I, N, 7 + bge $r0, I, .L999 + .align 3 + +.L114: + fld.d $f12, X, 0 * SIZE + fld.d $f14, Y, 0 * SIZE + addi.d I, I, -1 + fmadd.d $f14, $f12, $f0, $f14 + fst.d $f14, Y, 0 * SIZE + addi.d X, X, SIZE + addi.d Y, Y, SIZE + blt $r0, I, .L114 + b .L999 + .align 3 + +.L12: // INCX==1 and INCY!=1 + bge $r0, I, .L122 + move YY, Y + .align 3 + +.L121: + xvld VX0, X, 0 * SIZE + ld.d t1, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t2, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t3, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t4, Y, 0 * SIZE + xvinsgr2vr.d VX2, t1, 0 + xvinsgr2vr.d VX2, t2, 1 + xvinsgr2vr.d VX2, t3, 2 + xvinsgr2vr.d VX2, t4, 3 + add.d Y, Y, INCY + xvfmadd.d VX2, VX0, VXA, VX2 + xvld VX1, X, 4 * SIZE + xvstelm.d VX2, YY, 0, 0 + add.d YY, YY, INCY + xvstelm.d VX2, YY, 0, 1 + add.d YY, YY, INCY + xvstelm.d VX2, YY, 0, 2 + add.d YY, YY, INCY + xvstelm.d VX2, YY, 0, 3 + add.d YY, YY, INCY + ld.d t1, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t2, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t3, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t4, Y, 0 * SIZE + xvinsgr2vr.d VX3, t1, 0 + xvinsgr2vr.d VX3, t2, 1 + xvinsgr2vr.d VX3, t3, 2 + xvinsgr2vr.d VX3, t4, 3 + add.d Y, Y, INCY + xvfmadd.d VX3, VX1, VXA, VX3 + addi.d I, I, -1 + xvstelm.d VX3, YY, 0, 0 + add.d YY, YY, INCY + xvstelm.d VX3, YY, 0, 1 + add.d YY, YY, INCY + xvstelm.d VX3, YY, 0, 2 + add.d YY, YY, INCY + xvstelm.d VX3, YY, 0, 3 + add.d YY, YY, INCY + addi.d X, X, 8 * SIZE + blt $r0, I, .L121 + .align 3 + +.L122: + andi I, N, 7 + bge $r0, I, .L999 + .align 3 + +.L123: + fld.d $f12, X, 0 * SIZE + fld.d $f14, Y, 0 * SIZE + addi.d I, I, -1 + fmadd.d $f14, $f12, $f0, $f14 + fst.d $f14, Y, 0 * SIZE + addi.d X, X, SIZE + add.d Y, Y, INCY + blt $r0, I, .L123 + b .L999 + .align 3 + +.L21:// INCX!=1 and INCY==1 + bge $r0, I, .L212 + .align 3 + +.L211: + xvld VX2, Y, 0 * SIZE + ld.d t1, X, 0 * SIZE + add.d X, X, INCX + ld.d t2, X, 0 * SIZE + add.d X, X, INCX + ld.d t3, X, 0 * SIZE + add.d X, X, INCX + ld.d t4, X, 0 * SIZE + xvinsgr2vr.d VX0, t1, 0 + xvinsgr2vr.d VX0, t2, 1 + xvinsgr2vr.d VX0, t3, 2 + xvinsgr2vr.d VX0, t4, 3 + add.d X, X, INCX + xvfmadd.d VX2, VX0, VXA, VX2 + xvld VX3, Y, 4 * SIZE + xvst VX2, Y, 0 * SIZE + ld.d t1, X, 0 * SIZE + add.d X, X, INCX + ld.d t2, X, 0 * SIZE + add.d X, X, INCX + ld.d t3, X, 0 * SIZE + add.d X, X, INCX + ld.d t4, X, 0 * SIZE + xvinsgr2vr.d VX1, t1, 0 + xvinsgr2vr.d VX1, t2, 1 + xvinsgr2vr.d VX1, t3, 2 + xvinsgr2vr.d VX1, t4, 3 + add.d X, X, INCX + xvfmadd.d VX3, VX1, VXA, VX3 + addi.d I, I, -1 + xvst VX3, Y, 4 * SIZE + addi.d Y, Y, 8 * SIZE + blt $r0, I, .L211 + .align 3 + +.L212: + andi I, N, 7 + bge $r0, I, .L999 + .align 3 + +.L213: + fld.d $f12, X, 0 * SIZE + fld.d $f14, Y, 0 * SIZE + addi.d I, I, -1 + fmadd.d $f14, $f12, $f0, $f14 + fst.d $f14, Y, 0 * SIZE + add.d X, X, INCX + addi.d Y, Y, SIZE + blt $r0, I, .L213 + b .L999 + .align 3 + +.L22: + bge $r0, I, .L223 + move YY, Y + .align 3 + +.L222: + ld.d t1, X, 0 * SIZE + add.d X, X, INCX + ld.d t2, X, 0 * SIZE + add.d X, X, INCX + ld.d t3, X, 0 * SIZE + add.d X, X, INCX + ld.d t4, X, 0 * SIZE + xvinsgr2vr.d VX0, t1, 0 + xvinsgr2vr.d VX0, t2, 1 + xvinsgr2vr.d VX0, t3, 2 + xvinsgr2vr.d VX0, t4, 3 + add.d X, X, INCX + ld.d t1, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t2, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t3, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t4, Y, 0 * SIZE + xvinsgr2vr.d VX2, t1, 0 + xvinsgr2vr.d VX2, t2, 1 + xvinsgr2vr.d VX2, t3, 2 + xvinsgr2vr.d VX2, t4, 3 + add.d Y, Y, INCY + xvfmadd.d VX2, VX0, VXA, VX2 + ld.d t1, X, 0 * SIZE + add.d X, X, INCX + ld.d t2, X, 0 * SIZE + add.d X, X, INCX + ld.d t3, X, 0 * SIZE + add.d X, X, INCX + ld.d t4, X, 0 * SIZE + add.d X, X, INCX + xvinsgr2vr.d VX1, t1, 0 + xvinsgr2vr.d VX1, t2, 1 + xvinsgr2vr.d VX1, t3, 2 + xvinsgr2vr.d VX1, t4, 3 + xvstelm.d VX2, YY, 0, 0 + add.d YY, YY, INCY + xvstelm.d VX2, YY, 0, 1 + add.d YY, YY, INCY + xvstelm.d VX2, YY, 0, 2 + add.d YY, YY, INCY + xvstelm.d VX2, YY, 0, 3 + add.d YY, YY, INCY + ld.d t1, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t2, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t3, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t4, Y, 0 * SIZE + xvinsgr2vr.d VX3, t1, 0 + xvinsgr2vr.d VX3, t2, 1 + xvinsgr2vr.d VX3, t3, 2 + xvinsgr2vr.d VX3, t4, 3 + add.d Y, Y, INCY + xvfmadd.d VX3, VX1, VXA, VX3 + addi.d I, I, -1 + xvstelm.d VX3, YY, 0, 0 + add.d YY, YY, INCY + xvstelm.d VX3, YY, 0, 1 + add.d YY, YY, INCY + xvstelm.d VX3, YY, 0, 2 + add.d YY, YY, INCY + xvstelm.d VX3, YY, 0, 3 + add.d YY, YY, INCY + blt $r0, I, .L222 + .align 3 + +.L223: + andi I, N, 7 + bge $r0, I, .L999 + .align 3 + +.L224: + fld.d $f12, X, 0 * SIZE + fld.d $f14, Y, 0 * SIZE + addi.d I, I, -1 + fmadd.d $f14, $f12, $f0, $f14 + fst.d $f14, Y, 0 * SIZE + add.d X, X, INCX + add.d Y, Y, INCY + blt $r0, I, .L224 + b .L999 + .align 3 + +.L999: + move $r4, $r12 + jirl $r0, $r1, 0x0 + .align 3 + + EPILOGUE diff --git a/kernel/loongarch64/daxpy_lsx.S b/kernel/loongarch64/daxpy_lsx.S new file mode 100644 index 000000000..fc88f0bb9 --- /dev/null +++ b/kernel/loongarch64/daxpy_lsx.S @@ -0,0 +1,365 @@ +#define ASSEMBLER + +#include "common.h" +#define N $r4 +#define XX $r5 +#define YY $r6 +#define ALPHA $f0 +#define X $r7 +#define INCX $r8 +#define Y $r9 +#define INCY $r10 + +#define I $r12 +#define TEMP $r13 +#define t1 $r14 +#define t2 $r16 +#define t3 $r15 +#define t4 $r17 +#define a1 $f12 +#define a2 $f13 +#define a3 $f14 +#define a4 $f15 +#define b1 $f16 +#define b2 $f17 +#define b3 $f18 +#define b4 $f19 +#define VX0 $vr8 +#define VX1 $vr20 +#define VX2 $vr21 +#define VX3 $vr22 +#define VXA $vr23 + + PROLOGUE + + bge $r0, N, .L999 + li.d TEMP, 1 + movgr2fr.d a1, $r0 + ffint.d.l a1, a1 + movgr2fr.d a2, TEMP + ffint.d.l a2, a2 + fcmp.ceq.d $fcc0, ALPHA, a1 + bcnez $fcc0, .L999 + slli.d TEMP, TEMP, BASE_SHIFT + slli.d INCX, INCX, BASE_SHIFT + slli.d INCY, INCY, BASE_SHIFT + movfr2gr.d t1, ALPHA + vreplgr2vr.d VXA, t1 + + srai.d I, N, 3 + bne INCX, TEMP, .L20 + bne INCY, TEMP, .L12 // INCX==1 and INCY!=1 + b .L11 // INCX==1 and INCY==1 +.L20: + bne INCY, TEMP, .L22 // INCX!=1 and INCY!=1 + b .L21 // INCX!=1 and INCY==1 + +.L11: + bge $r0, I, .L113 + fcmp.ceq.d $fcc0, ALPHA, a2 + bceqz $fcc0, .L112 + .align 3 + +.L111: + vld VX0, X, 0 * SIZE + vld VX2, Y, 0 * SIZE + vld VX1, X, 2 * SIZE + vld VX3, Y, 2 * SIZE + vfadd.d VX2, VX0, VX2 + vfadd.d VX3, VX1, VX3 + vst VX2, Y, 0 * SIZE + vst VX3, Y, 2 * SIZE + vld VX0, X, 4 * SIZE + vld VX2, Y, 4 * SIZE + vld VX1, X, 6 * SIZE + vld VX3, Y, 6 * SIZE + vfadd.d VX2, VX0, VX2 + vfadd.d VX3, VX1, VX3 + addi.d I, I, -1 + vst VX2, Y, 4 * SIZE + vst VX3, Y, 6 * SIZE + addi.d X, X, 8 * SIZE + addi.d Y, Y, 8 * SIZE + blt $r0, I, .L111 + b .L113 + .align 3 + +.L112: + vld VX0, X, 0 * SIZE + vld VX2, Y, 0 * SIZE + vld VX1, X, 2 * SIZE + vld VX3, Y, 2 * SIZE + vfmadd.d VX2, VX0, VXA, VX2 + vfmadd.d VX3, VX1, VXA, VX3 + addi.d I, I, -1 + vst VX2, Y, 0 * SIZE + vst VX3, Y, 2 * SIZE + vld VX0, X, 4 * SIZE + vld VX2, Y, 4 * SIZE + vld VX1, X, 6 * SIZE + vld VX3, Y, 6 * SIZE + addi.d X, X, 8 * SIZE + vfmadd.d VX2, VX0, VXA, VX2 + vfmadd.d VX3, VX1, VXA, VX3 + vst VX2, Y, 4 * SIZE + vst VX3, Y, 6 * SIZE + addi.d Y, Y, 8 * SIZE + blt $r0, I, .L112 + .align 3 + +.L113: + andi I, N, 7 + bge $r0, I, .L999 + .align 3 + +.L114: + fld.d $f12, X, 0 * SIZE + fld.d $f14, Y, 0 * SIZE + addi.d I, I, -1 + fmadd.d $f14, $f12, $f0, $f14 + fst.d $f14, Y, 0 * SIZE + addi.d X, X, SIZE + addi.d Y, Y, SIZE + blt $r0, I, .L114 + b .L999 + .align 3 + +.L12: // INCX==1 and INCY!=1 + bge $r0, I, .L122 + move YY, Y + .align 3 + +.L121: + vld VX0, X, 0 * SIZE + ld.d t1, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t2, Y, 0 * SIZE + vinsgr2vr.d VX2, t1, 0 + vinsgr2vr.d VX2, t2, 1 + add.d Y, Y, INCY + vfmadd.d VX2, VX0, VXA, VX2 + vld VX1, X, 2 * SIZE + vstelm.d VX2, YY, 0, 0 + add.d YY, YY, INCY + vstelm.d VX2, YY, 0, 1 + add.d YY, YY, INCY + ld.d t3, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t4, Y, 0 * SIZE + vinsgr2vr.d VX3, t3, 0 + vinsgr2vr.d VX3, t4, 1 + add.d Y, Y, INCY + vfmadd.d VX3, VX1, VXA, VX3 + vld VX0, X, 4 * SIZE + vstelm.d VX3, YY, 0, 0 + add.d YY, YY, INCY + vstelm.d VX3, YY, 0, 1 + add.d YY, YY, INCY + ld.d t1, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t2, Y, 0 * SIZE + vinsgr2vr.d VX2, t1, 0 + vinsgr2vr.d VX2, t2, 1 + add.d Y, Y, INCY + vfmadd.d VX2, VX0, VXA, VX2 + vld VX1, X, 6 * SIZE + vstelm.d VX2, YY, 0, 0 + add.d YY, YY, INCY + vstelm.d VX2, YY, 0, 1 + add.d YY, YY, INCY + ld.d t3, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t4, Y, 0 * SIZE + vinsgr2vr.d VX3, t3, 0 + vinsgr2vr.d VX3, t4, 1 + add.d Y, Y, INCY + vfmadd.d VX3, VX1, VXA, VX3 + vstelm.d VX3, YY, 0, 0 + add.d YY, YY, INCY + vstelm.d VX3, YY, 0, 1 + add.d YY, YY, INCY + addi.d X, X, 8 * SIZE + addi.d I, I, -1 + blt $r0, I, .L121 + .align 3 + +.L122: + andi I, N, 7 + bge $r0, I, .L999 + .align 3 + +.L123: + fld.d $f12, X, 0 * SIZE + fld.d $f14, Y, 0 * SIZE + addi.d I, I, -1 + fmadd.d $f14, $f12, $f0, $f14 + fst.d $f14, Y, 0 * SIZE + addi.d X, X, SIZE + add.d Y, Y, INCY + blt $r0, I, .L123 + b .L999 + .align 3 + +.L21:// INCX!=1 and INCY==1 + bge $r0, I, .L212 + .align 3 + +.L211: + vld VX2, Y, 0 * SIZE + ld.d t1, X, 0 * SIZE + add.d X, X, INCX + ld.d t2, X, 0 * SIZE + vinsgr2vr.d VX0, t1, 0 + vinsgr2vr.d VX0, t2, 1 + add.d X, X, INCX + vfmadd.d VX2, VX0, VXA, VX2 + vld VX3, Y, 2 * SIZE + vst VX2, Y, 0 * SIZE + ld.d t3, X, 0 * SIZE + add.d X, X, INCX + ld.d t4, X, 0 * SIZE + vinsgr2vr.d VX1, t3, 0 + vinsgr2vr.d VX1, t4, 1 + add.d X, X, INCX + vfmadd.d VX3, VX1, VXA, VX3 + vld VX2, Y, 4 * SIZE + vst VX3, Y, 2 * SIZE + ld.d t1, X, 0 * SIZE + add.d X, X, INCX + ld.d t2, X, 0 * SIZE + vinsgr2vr.d VX0, t1, 0 + vinsgr2vr.d VX0, t2, 1 + add.d X, X, INCX + vfmadd.d VX2, VX0, VXA, VX2 + vld VX3, Y, 6 * SIZE + vst VX2, Y, 4 * SIZE + ld.d t3, X, 0 * SIZE + add.d X, X, INCX + ld.d t4, X, 0 * SIZE + vinsgr2vr.d VX1, t3, 0 + vinsgr2vr.d VX1, t4, 1 + add.d X, X, INCX + vfmadd.d VX3, VX1, VXA, VX3 + addi.d I, I, -1 + vst VX3, Y, 6 * SIZE + addi.d Y, Y, 8 * SIZE + blt $r0, I, .L211 + .align 3 + +.L212: + andi I, N, 7 + bge $r0, I, .L999 + .align 3 + +.L213: + fld.d $f12, X, 0 * SIZE + fld.d $f14, Y, 0 * SIZE + addi.d I, I, -1 + fmadd.d $f14, $f12, $f0, $f14 + fst.d $f14, Y, 0 * SIZE + add.d X, X, INCX + addi.d Y, Y, SIZE + blt $r0, I, .L213 + b .L999 + .align 3 + +.L22: + bge $r0, I, .L223 + move YY, Y + .align 3 + +.L222: + ld.d t1, X, 0 * SIZE + add.d X, X, INCX + ld.d t2, X, 0 * SIZE + add.d X, X, INCX + vinsgr2vr.d VX0, t1, 0 + vinsgr2vr.d VX0, t2, 1 + ld.d t1, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t2, Y, 0 * SIZE + vinsgr2vr.d VX2, t1, 0 + vinsgr2vr.d VX2, t2, 1 + add.d Y, Y, INCY + vfmadd.d VX2, VX0, VXA, VX2 + ld.d t3, X, 0 * SIZE + add.d X, X, INCX + ld.d t4, X, 0 * SIZE + add.d X, X, INCX + vinsgr2vr.d VX1, t3, 0 + vinsgr2vr.d VX1, t4, 1 + vstelm.d VX2, YY, 0, 0 + add.d YY, YY, INCY + vstelm.d VX2, YY, 0, 1 + add.d YY, YY, INCY + ld.d t3, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t4, Y, 0 * SIZE + vinsgr2vr.d VX3, t3, 0 + vinsgr2vr.d VX3, t4, 1 + add.d Y, Y, INCY + vfmadd.d VX3, VX1, VXA, VX3 + ld.d t1, X, 0 * SIZE + add.d X, X, INCX + ld.d t2, X, 0 * SIZE + add.d X, X, INCX + vinsgr2vr.d VX0, t1, 0 + vinsgr2vr.d VX0, t2, 1 + vstelm.d VX3, YY, 0, 0 + add.d YY, YY, INCY + vstelm.d VX3, YY, 0, 1 + add.d YY, YY, INCY + ld.d t1, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t2, Y, 0 * SIZE + vinsgr2vr.d VX2, t1, 0 + vinsgr2vr.d VX2, t2, 1 + add.d Y, Y, INCY + vfmadd.d VX2, VX0, VXA, VX2 + ld.d t3, X, 0 * SIZE + add.d X, X, INCX + ld.d t4, X, 0 * SIZE + add.d X, X, INCX + vinsgr2vr.d VX1, t3, 0 + vinsgr2vr.d VX1, t4, 1 + vstelm.d VX2, YY, 0, 0 + add.d YY, YY, INCY + vstelm.d VX2, YY, 0, 1 + add.d YY, YY, INCY + ld.d t1, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t2, Y, 0 * SIZE + vinsgr2vr.d VX3, t1, 0 + vinsgr2vr.d VX3, t2, 1 + add.d Y, Y, INCY + vfmadd.d VX3, VX1, VXA, VX3 + addi.d I, I, -1 + vstelm.d VX3, YY, 0, 0 + add.d YY, YY, INCY + vstelm.d VX3, YY, 0, 1 + add.d YY, YY, INCY + blt $r0, I, .L222 + .align 3 + +.L223: + andi I, N, 7 + bge $r0, I, .L999 + .align 3 + +.L224: + fld.d $f12, X, 0 * SIZE + fld.d $f14, Y, 0 * SIZE + addi.d I, I, -1 + fmadd.d $f14, $f12, $f0, $f14 + fst.d $f14, Y, 0 * SIZE + add.d X, X, INCX + add.d Y, Y, INCY + blt $r0, I, .L224 + .align 3 + +.L999: + move $r4, $r12 + jirl $r0, $r1, 0x0 + .align 3 + + EPILOGUE diff --git a/kernel/loongarch64/saxpby_lasx.S b/kernel/loongarch64/saxpby_lasx.S new file mode 100644 index 000000000..c5d1ff402 --- /dev/null +++ b/kernel/loongarch64/saxpby_lasx.S @@ -0,0 +1,597 @@ +#define ASSEMBLER + +#include "common.h" +#define N $r4 +#define ALPHA $f0 +#define X $r5 +#define INCX $r6 +#define BETA $f1 +#define Y $r7 +#define INCY $r8 + +#define I $r12 +#define TEMP $r13 +#define t1 $r14 +#define t2 $r16 +#define t3 $r15 +#define t4 $r17 +#define XX $r18 +#define YY $r19 +#define a1 $f12 +#define a2 $f13 +#define VX0 $xr8 +#define VX1 $xr20 +#define VX2 $xr21 +#define VX3 $xr22 +#define VXA $xr23 +#define VXB $xr9 +#define VXZ $xr19 + + PROLOGUE + + bge $r0, N, .L999 + li.d TEMP, 1 + movgr2fr.d a1, $r0 + ffint.s.l a1, a1 + slli.d TEMP, TEMP, BASE_SHIFT + slli.d INCX, INCX, BASE_SHIFT + slli.d INCY, INCY, BASE_SHIFT + movfr2gr.s t1, ALPHA + xvreplgr2vr.w VXA, t1 + movfr2gr.s t2, BETA + xvreplgr2vr.w VXB, t2 + movfr2gr.s t3, a1 + xvreplgr2vr.w VXZ, t3 + srai.d I, N, 3 + bne INCX, TEMP, .L20 + bne INCY, TEMP, .L12 // INCX==1 and INCY!=1 + b .L11 // INCX==1 and INCY==1 +.L20: + bne INCY, TEMP, .L22 // INCX!=1 and INCY!=1 + b .L21 // INCX!=1 and INCY==1 + +.L11: + bge $r0, I, .L997 + fcmp.ceq.s $fcc0, ALPHA, a1 + bcnez $fcc0, .L110 + fcmp.ceq.s $fcc0, BETA, a1 + bcnez $fcc0, .L112 // ALPHA!=0 BETA==0 + b .L111 // ALPHA!=0 BETA!=0 + .align 3 + +.L110: + fcmp.ceq.s $fcc0, BETA, a1 + bcnez $fcc0, .L114 // ALPHA==0 BETA==0 + b .L113 // ALPHA==0 BETA!=0 + .align 3 + +.L111: // ALPHA!=0 BETA!=0 + xvld VX0, X, 0 * SIZE + xvld VX2, Y, 0 * SIZE + xvfmul.s VX0, VX0, VXA + addi.d I, I, -1 + xvfmadd.s VX2, VX2, VXB, VX0 + xvst VX2, Y, 0 * SIZE + addi.d X, X, 8 * SIZE + addi.d Y, Y, 8 * SIZE + blt $r0, I, .L111 + b .L997 + .align 3 + +.L112: // ALPHA!=0 BETA==0 + xvld VX0, X, 0 * SIZE + xvfmul.s VX0, VX0, VXA + addi.d I, I, -1 + xvst VX0, Y, 0 * SIZE + addi.d X, X, 8 * SIZE + addi.d Y, Y, 8 * SIZE + blt $r0, I, .L112 + b .L997 + .align 3 + +.L113: // ALPHA==0 BETA!=0 + xvld VX2, Y, 0 * SIZE + xvfmul.s VX2, VX2, VXB + addi.d I, I, -1 + xvst VX2, Y, 0 * SIZE + addi.d Y, Y, 8 * SIZE + blt $r0, I, .L113 + b .L997 + .align 3 + +.L114: // ALPHA==0 BETA==0 + xvst VXZ, Y, 0 * SIZE + addi.d Y, Y, 8 * SIZE + addi.d I, I, -1 + blt $r0, I, .L114 + b .L997 + .align 3 + +.L12: // INCX==1 and INCY!=1 + bge $r0, I, .L997 + move YY, Y + fcmp.ceq.s $fcc0, ALPHA, a1 + bcnez $fcc0, .L120 + fcmp.ceq.s $fcc0, BETA, a1 + bcnez $fcc0, .L122 // ALPHA!=0 BETA==0 + b .L121 // ALPHA!=0 BETA!=0 + .align 3 + +.L120: + fcmp.ceq.s $fcc0, BETA, a1 + bcnez $fcc0, .L124 // ALPHA==0 BETA==0 + b .L123 // ALPHA==0 BETA!=0 + .align 3 + +.L121: // ALPHA!=0 BETA!=0 + xvld VX0, X, 0 * SIZE + ld.w t1, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t2, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t3, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t4, Y, 0 * SIZE + add.d Y, Y, INCY + xvinsgr2vr.w VX2, t1, 0 + xvinsgr2vr.w VX2, t2, 1 + xvinsgr2vr.w VX2, t3, 2 + xvinsgr2vr.w VX2, t4, 3 + ld.w t1, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t2, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t3, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t4, Y, 0 * SIZE + xvinsgr2vr.w VX2, t1, 4 + xvinsgr2vr.w VX2, t2, 5 + xvinsgr2vr.w VX2, t3, 6 + xvinsgr2vr.w VX2, t4, 7 + add.d Y, Y, INCY + xvfmul.s VX0, VX0, VXA + xvfmadd.s VX2, VX2, VXB, VX0 + xvstelm.w VX2, YY, 0, 0 + add.d YY, YY, INCY + xvstelm.w VX2, YY, 0, 1 + add.d YY, YY, INCY + xvstelm.w VX2, YY, 0, 2 + add.d YY, YY, INCY + xvstelm.w VX2, YY, 0, 3 + add.d YY, YY, INCY + xvstelm.w VX2, YY, 0, 4 + add.d YY, YY, INCY + xvstelm.w VX2, YY, 0, 5 + add.d YY, YY, INCY + xvstelm.w VX2, YY, 0, 6 + add.d YY, YY, INCY + xvstelm.w VX2, YY, 0, 7 + add.d YY, YY, INCY + addi.d X, X, 8 * SIZE + addi.d I, I, -1 + blt $r0, I, .L121 + b .L997 + .align 3 + +.L122: // ALPHA!=0 BETA==0 + xvld VX0, X, 0 * SIZE + xvfmul.s VX0, VX0, VXA + addi.d I, I, -1 + xvstelm.w VX0, YY, 0, 0 + add.d YY, YY, INCY + xvstelm.w VX0, YY, 0, 1 + add.d YY, YY, INCY + xvstelm.w VX0, YY, 0, 2 + add.d YY, YY, INCY + xvstelm.w VX0, YY, 0, 3 + add.d YY, YY, INCY + xvstelm.w VX0, YY, 0, 4 + add.d YY, YY, INCY + xvstelm.w VX0, YY, 0, 5 + add.d YY, YY, INCY + xvstelm.w VX0, YY, 0, 6 + add.d YY, YY, INCY + xvstelm.w VX0, YY, 0, 7 + add.d YY, YY, INCY + addi.d X, X, 8 * SIZE + blt $r0, I, .L122 + b .L997 + .align 3 + +.L123: // ALPHA==0 BETA!=0 + ld.w t1, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t2, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t3, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t4, Y, 0 * SIZE + add.d Y, Y, INCY + xvinsgr2vr.w VX2, t1, 0 + xvinsgr2vr.w VX2, t2, 1 + xvinsgr2vr.w VX2, t3, 2 + xvinsgr2vr.w VX2, t4, 3 + ld.w t1, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t2, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t3, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t4, Y, 0 * SIZE + xvinsgr2vr.w VX2, t1, 4 + xvinsgr2vr.w VX2, t2, 5 + xvinsgr2vr.w VX2, t3, 6 + xvinsgr2vr.w VX2, t4, 7 + add.d Y, Y, INCY + xvfmul.s VX2, VX2, VXB + xvstelm.w VX2, YY, 0, 0 + add.d YY, YY, INCY + xvstelm.w VX2, YY, 0, 1 + add.d YY, YY, INCY + xvstelm.w VX2, YY, 0, 2 + add.d YY, YY, INCY + xvstelm.w VX2, YY, 0, 3 + add.d YY, YY, INCY + xvstelm.w VX2, YY, 0, 4 + add.d YY, YY, INCY + xvstelm.w VX2, YY, 0, 5 + add.d YY, YY, INCY + xvstelm.w VX2, YY, 0, 6 + add.d YY, YY, INCY + xvstelm.w VX2, YY, 0, 7 + add.d YY, YY, INCY + addi.d I, I, -1 + blt $r0, I, .L123 + b .L997 + .align 3 + +.L124: // ALPHA==0 BETA==0 + xvstelm.w VXZ, YY, 0, 0 + add.d YY, YY, INCY + xvstelm.w VXZ, YY, 0, 1 + add.d YY, YY, INCY + xvstelm.w VXZ, YY, 0, 2 + add.d YY, YY, INCY + xvstelm.w VXZ, YY, 0, 3 + add.d YY, YY, INCY + xvstelm.w VXZ, YY, 0, 4 + add.d YY, YY, INCY + xvstelm.w VXZ, YY, 0, 5 + add.d YY, YY, INCY + xvstelm.w VXZ, YY, 0, 6 + add.d YY, YY, INCY + xvstelm.w VXZ, YY, 0, 7 + add.d YY, YY, INCY + addi.d I, I, -1 + blt $r0, I, .L124 + b .L997 + .align 3 + +.L21:// INCX!=1 and INCY==1 + bge $r0, I, .L997 + fcmp.ceq.s $fcc0, ALPHA, a1 + bcnez $fcc0, .L210 + fcmp.ceq.s $fcc0, BETA, a1 + bcnez $fcc0, .L212 // ALPHA!=0 BETA==0 + b .L211 // ALPHA!=0 BETA!=0 + .align 3 + +.L210: + fcmp.ceq.s $fcc0, BETA, a1 + bcnez $fcc0, .L214 // ALPHA==0 BETA==0 + b .L213 // ALPHA==0 BETA!=0 + .align 3 + +.L211: // ALPHA!=0 BETA!=0 + xvld VX2, Y, 0 * SIZE + ld.w t1, X, 0 * SIZE + add.d X, X, INCX + ld.w t2, X, 0 * SIZE + add.d X, X, INCX + ld.w t3, X, 0 * SIZE + add.d X, X, INCX + ld.w t4, X, 0 * SIZE + add.d X, X, INCX + xvinsgr2vr.w VX0, t1, 0 + xvinsgr2vr.w VX0, t2, 1 + xvinsgr2vr.w VX0, t3, 2 + xvinsgr2vr.w VX0, t4, 3 + ld.w t1, X, 0 * SIZE + add.d X, X, INCX + ld.w t2, X, 0 * SIZE + add.d X, X, INCX + ld.w t3, X, 0 * SIZE + add.d X, X, INCX + ld.w t4, X, 0 * SIZE + xvinsgr2vr.w VX0, t1, 4 + xvinsgr2vr.w VX0, t2, 5 + xvinsgr2vr.w VX0, t3, 6 + xvinsgr2vr.w VX0, t4, 7 + add.d X, X, INCX + xvfmul.s VX0, VXA, VX0 + xvfmadd.s VX2, VX2, VXB, VX0 + addi.d I, I, -1 + xvst VX2, Y, 0 * SIZE + addi.d Y, Y, 8 * SIZE + blt $r0, I, .L211 + b .L997 + .align 3 + +.L212: // ALPHA!=0 BETA==0 + ld.w t1, X, 0 * SIZE + add.d X, X, INCX + ld.w t2, X, 0 * SIZE + add.d X, X, INCX + ld.w t3, X, 0 * SIZE + add.d X, X, INCX + ld.w t4, X, 0 * SIZE + add.d X, X, INCX + xvinsgr2vr.w VX0, t1, 0 + xvinsgr2vr.w VX0, t2, 1 + xvinsgr2vr.w VX0, t3, 2 + xvinsgr2vr.w VX0, t4, 3 + ld.w t1, X, 0 * SIZE + add.d X, X, INCX + ld.w t2, X, 0 * SIZE + add.d X, X, INCX + ld.w t3, X, 0 * SIZE + add.d X, X, INCX + ld.w t4, X, 0 * SIZE + xvinsgr2vr.w VX0, t1, 4 + xvinsgr2vr.w VX0, t2, 5 + xvinsgr2vr.w VX0, t3, 6 + xvinsgr2vr.w VX0, t4, 7 + add.d X, X, INCX + xvfmul.s VX0, VXA, VX0 + addi.d I, I, -1 + xvst VX0, Y, 0 * SIZE + addi.d Y, Y, 8 * SIZE + blt $r0, I, .L212 + b .L997 + .align 3 + +.L213: // ALPHA==0 BETA!=0 + xvld VX2, Y, 0 * SIZE + xvfmul.s VX2, VX2, VXB + xvst VX2, Y, 0 * SIZE + addi.d Y, Y, 8 * SIZE + addi.d I, I, -1 + blt $r0, I, .L213 + b .L997 + .align 3 + +.L214: // ALPHA==0 BETA==0 + xvst VXZ, Y, 0 * SIZE + addi.d Y, Y, 8 * SIZE + addi.d I, I, -1 + blt $r0, I, .L214 + b .L997 + .align 3 + +.L22: + bge $r0, I, .L997 + move YY, Y + fcmp.ceq.s $fcc0, ALPHA, a1 + bcnez $fcc0, .L220 + fcmp.ceq.s $fcc0, BETA, a1 + bcnez $fcc0, .L222 // ALPHA!=0 BETA==0 + b .L221 // ALPHA!=0 BETA!=0 + .align 3 + +.L220: + fcmp.ceq.s $fcc0, BETA, a1 + bcnez $fcc0, .L224 // ALPHA==0 BETA==0 + b .L223 // ALPHA==0 BETA!=0 + .align 3 + +.L221: // ALPHA!=0 BETA!=0 + ld.w t1, X, 0 * SIZE + add.d X, X, INCX + ld.w t2, X, 0 * SIZE + add.d X, X, INCX + ld.w t3, X, 0 * SIZE + add.d X, X, INCX + ld.w t4, X, 0 * SIZE + add.d X, X, INCX + xvinsgr2vr.w VX0, t1, 0 + xvinsgr2vr.w VX0, t2, 1 + xvinsgr2vr.w VX0, t3, 2 + xvinsgr2vr.w VX0, t4, 3 + ld.w t1, X, 0 * SIZE + add.d X, X, INCX + ld.w t2, X, 0 * SIZE + add.d X, X, INCX + ld.w t3, X, 0 * SIZE + add.d X, X, INCX + ld.w t4, X, 0 * SIZE + xvinsgr2vr.w VX0, t1, 4 + xvinsgr2vr.w VX0, t2, 5 + xvinsgr2vr.w VX0, t3, 6 + xvinsgr2vr.w VX0, t4, 7 + add.d X, X, INCX + ld.w t1, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t2, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t3, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t4, Y, 0 * SIZE + xvinsgr2vr.w VX2, t1, 0 + xvinsgr2vr.w VX2, t2, 1 + xvinsgr2vr.w VX2, t3, 2 + xvinsgr2vr.w VX2, t4, 3 + add.d Y, Y, INCY + ld.w t1, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t2, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t3, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t4, Y, 0 * SIZE + xvinsgr2vr.w VX2, t1, 4 + xvinsgr2vr.w VX2, t2, 5 + xvinsgr2vr.w VX2, t3, 6 + xvinsgr2vr.w VX2, t4, 7 + add.d Y, Y, INCY + xvfmul.s VX0, VX0, VXA + xvfmadd.s VX2, VX2, VXB, VX0 + addi.d I, I, -1 + xvstelm.w VX2, YY, 0, 0 + add.d YY, YY, INCY + xvstelm.w VX2, YY, 0, 1 + add.d YY, YY, INCY + xvstelm.w VX2, YY, 0, 2 + add.d YY, YY, INCY + xvstelm.w VX2, YY, 0, 3 + add.d YY, YY, INCY + xvstelm.w VX2, YY, 0, 4 + add.d YY, YY, INCY + xvstelm.w VX2, YY, 0, 5 + add.d YY, YY, INCY + xvstelm.w VX2, YY, 0, 6 + add.d YY, YY, INCY + xvstelm.w VX2, YY, 0, 7 + add.d YY, YY, INCY + blt $r0, I, .L221 + b .L997 + .align 3 + +.L222: // ALPHA!=0 BETA==0 + ld.w t1, X, 0 * SIZE + add.d X, X, INCX + ld.w t2, X, 0 * SIZE + add.d X, X, INCX + ld.w t3, X, 0 * SIZE + add.d X, X, INCX + ld.w t4, X, 0 * SIZE + xvinsgr2vr.w VX0, t1, 0 + xvinsgr2vr.w VX0, t2, 1 + xvinsgr2vr.w VX0, t3, 2 + xvinsgr2vr.w VX0, t4, 3 + add.d X, X, INCX + ld.w t1, X, 0 * SIZE + add.d X, X, INCX + ld.w t2, X, 0 * SIZE + add.d X, X, INCX + ld.w t3, X, 0 * SIZE + add.d X, X, INCX + ld.w t4, X, 0 * SIZE + xvinsgr2vr.w VX0, t1, 4 + xvinsgr2vr.w VX0, t2, 5 + xvinsgr2vr.w VX0, t3, 6 + xvinsgr2vr.w VX0, t4, 7 + add.d X, X, INCX + xvfmul.s VX0, VX0, VXA + addi.d I, I, -1 + xvstelm.w VX0, YY, 0, 0 + add.d YY, YY, INCY + xvstelm.w VX0, YY, 0, 1 + add.d YY, YY, INCY + xvstelm.w VX0, YY, 0, 2 + add.d YY, YY, INCY + xvstelm.w VX0, YY, 0, 3 + add.d YY, YY, INCY + xvstelm.w VX0, YY, 0, 4 + add.d YY, YY, INCY + xvstelm.w VX0, YY, 0, 5 + add.d YY, YY, INCY + xvstelm.w VX0, YY, 0, 6 + add.d YY, YY, INCY + xvstelm.w VX0, YY, 0, 7 + add.d YY, YY, INCY + blt $r0, I, .L222 + b .L997 + .align 3 + +.L223: // ALPHA==0 BETA!=0 + ld.w t1, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t2, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t3, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t4, Y, 0 * SIZE + add.d Y, Y, INCY + xvinsgr2vr.w VX2, t1, 0 + xvinsgr2vr.w VX2, t2, 1 + xvinsgr2vr.w VX2, t3, 2 + xvinsgr2vr.w VX2, t4, 3 + ld.w t1, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t2, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t3, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t4, Y, 0 * SIZE + xvinsgr2vr.w VX2, t1, 4 + xvinsgr2vr.w VX2, t2, 5 + xvinsgr2vr.w VX2, t3, 6 + xvinsgr2vr.w VX2, t4, 7 + add.d Y, Y, INCY + xvfmul.s VX2, VX2, VXB + addi.d I, I, -1 + xvstelm.w VX2, YY, 0, 0 + add.d YY, YY, INCY + xvstelm.w VX2, YY, 0, 1 + add.d YY, YY, INCY + xvstelm.w VX2, YY, 0, 2 + add.d YY, YY, INCY + xvstelm.w VX2, YY, 0, 3 + add.d YY, YY, INCY + xvstelm.w VX2, YY, 0, 4 + add.d YY, YY, INCY + xvstelm.w VX2, YY, 0, 5 + add.d YY, YY, INCY + xvstelm.w VX2, YY, 0, 6 + add.d YY, YY, INCY + xvstelm.w VX2, YY, 0, 7 + add.d YY, YY, INCY + blt $r0, I, .L223 + b .L997 + .align 3 + +.L224: // ALPHA==0 BETA==0 + xvstelm.w VXZ, YY, 0, 0 + add.d YY, YY, INCY + xvstelm.w VXZ, YY, 0, 1 + add.d YY, YY, INCY + xvstelm.w VXZ, YY, 0, 2 + add.d YY, YY, INCY + xvstelm.w VXZ, YY, 0, 3 + add.d YY, YY, INCY + xvstelm.w VXZ, YY, 0, 4 + add.d YY, YY, INCY + xvstelm.w VXZ, YY, 0, 5 + add.d YY, YY, INCY + xvstelm.w VXZ, YY, 0, 6 + add.d YY, YY, INCY + xvstelm.w VXZ, YY, 0, 7 + add.d YY, YY, INCY + addi.d I, I, -1 + blt $r0, I, .L224 + b .L997 + .align 3 + +.L997: + andi I, N, 7 + bge $r0, I, .L999 + .align 3 + +.L998: + fld.s $f12, X, 0 * SIZE + fld.s $f13, Y, 0 * SIZE + addi.d I, I, -1 + fmul.s $f12, $f12, ALPHA + fmadd.s $f13, $f13, BETA, $f12 + fst.s $f13, Y, 0 * SIZE + add.d X, X, INCX + add.d Y, Y, INCY + blt $r0, I, .L998 + .align 3 + +.L999: + move $r4, $r12 + jirl $r0, $r1, 0x0 + .align 3 + + EPILOGUE diff --git a/kernel/loongarch64/saxpby_lsx.S b/kernel/loongarch64/saxpby_lsx.S new file mode 100644 index 000000000..7f8cea2dd --- /dev/null +++ b/kernel/loongarch64/saxpby_lsx.S @@ -0,0 +1,629 @@ +#define ASSEMBLER + +#include "common.h" +#define N $r4 +#define ALPHA $f0 +#define X $r5 +#define INCX $r6 +#define BETA $f1 +#define Y $r7 +#define INCY $r8 + +#define I $r12 +#define TEMP $r13 +#define t1 $r14 +#define t2 $r16 +#define t3 $r15 +#define t4 $r17 +#define XX $r18 +#define YY $r19 +#define a1 $f12 +#define a2 $f13 +#define VX0 $vr8 +#define VX1 $vr20 +#define VX2 $vr21 +#define VX3 $vr22 +#define VXA $vr23 +#define VXB $vr9 +#define VXZ $vr19 + + PROLOGUE + + bge $r0, N, .L999 + li.d TEMP, 1 + movgr2fr.d a1, $r0 + ffint.s.l a1, a1 + slli.d TEMP, TEMP, BASE_SHIFT + slli.d INCX, INCX, BASE_SHIFT + slli.d INCY, INCY, BASE_SHIFT + movfr2gr.s t1, ALPHA + vreplgr2vr.w VXA, t1 + movfr2gr.s t2, BETA + vreplgr2vr.w VXB, t2 + movfr2gr.s t3, a1 + vreplgr2vr.w VXZ, t3 + srai.d I, N, 3 + bne INCX, TEMP, .L20 + bne INCY, TEMP, .L12 // INCX==1 and INCY!=1 + b .L11 // INCX==1 and INCY==1 +.L20: + bne INCY, TEMP, .L22 // INCX!=1 and INCY!=1 + b .L21 // INCX!=1 and INCY==1 + +.L11: + bge $r0, I, .L997 + fcmp.ceq.s $fcc0, ALPHA, a1 + bcnez $fcc0, .L110 + fcmp.ceq.s $fcc0, BETA, a1 + bcnez $fcc0, .L112 // ALPHA!=0 BETA==0 + b .L111 // ALPHA!=0 BETA!=0 + .align 3 + +.L110: + fcmp.ceq.s $fcc0, BETA, a1 + bcnez $fcc0, .L114 // ALPHA==0 BETA==0 + b .L113 // ALPHA==0 BETA!=0 + .align 3 + +.L111: // ALPHA!=0 BETA!=0 + vld VX0, X, 0 * SIZE + vld VX2, Y, 0 * SIZE + vld VX1, X, 4 * SIZE + vld VX3, Y, 4 * SIZE + vfmul.s VX0, VX0, VXA + vfmul.s VX1, VX1, VXA + vfmadd.s VX2, VX2, VXB, VX0 + vfmadd.s VX3, VX3, VXB, VX1 + vst VX2, Y, 0 * SIZE + vst VX3, Y, 4 * SIZE + addi.d X, X, 8 * SIZE + addi.d Y, Y, 8 * SIZE + addi.d I, I, -1 + blt $r0, I, .L111 + b .L997 + .align 3 + +.L112: // ALPHA!=0 BETA==0 + vld VX0, X, 0 * SIZE + vld VX1, X, 4 * SIZE + vfmul.s VX0, VX0, VXA + vfmul.s VX1, VX1, VXA + vst VX0, Y, 0 * SIZE + vst VX1, Y, 4 * SIZE + addi.d X, X, 8 * SIZE + addi.d Y, Y, 8 * SIZE + addi.d I, I, -1 + blt $r0, I, .L112 + b .L997 + .align 3 + +.L113: // ALPHA==0 BETA!=0 + vld VX2, Y, 0 * SIZE + vld VX3, Y, 4 * SIZE + vfmul.s VX2, VX2, VXB + vfmul.s VX3, VX3, VXB + vst VX2, Y, 0 * SIZE + vst VX3, Y, 4 * SIZE + addi.d Y, Y, 8 * SIZE + addi.d I, I, -1 + blt $r0, I, .L113 + b .L997 + .align 3 + +.L114: // ALPHA==0 BETA==0 + vst VXZ, Y, 0 * SIZE + vst VXZ, Y, 4 * SIZE + addi.d Y, Y, 8 * SIZE + addi.d I, I, -1 + blt $r0, I, .L114 + b .L997 + .align 3 + +.L12: // INCX==1 and INCY!=1 + bge $r0, I, .L997 + move YY, Y + fcmp.ceq.s $fcc0, ALPHA, a1 + bcnez $fcc0, .L120 + fcmp.ceq.s $fcc0, BETA, a1 + bcnez $fcc0, .L122 // ALPHA!=0 BETA==0 + b .L121 // ALPHA!=0 BETA!=0 + .align 3 + +.L120: + fcmp.ceq.s $fcc0, BETA, a1 + bcnez $fcc0, .L124 // ALPHA==0 BETA==0 + b .L123 // ALPHA==0 BETA!=0 + .align 3 + +.L121: // ALPHA!=0 BETA!=0 + vld VX0, X, 0 * SIZE + ld.w t1, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t2, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t3, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t4, Y, 0 * SIZE + vinsgr2vr.w VX2, t1, 0 + vinsgr2vr.w VX2, t2, 1 + vinsgr2vr.w VX2, t3, 2 + vinsgr2vr.w VX2, t4, 3 + add.d Y, Y, INCY + vfmul.s VX0, VX0, VXA + vld VX1, X, 4 * SIZE + vfmadd.s VX2, VX2, VXB, VX0 + ld.w t1, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t2, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t3, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t4, Y, 0 * SIZE + add.d Y, Y, INCY + vinsgr2vr.w VX3, t1, 0 + vinsgr2vr.w VX3, t2, 1 + vinsgr2vr.w VX3, t3, 2 + vinsgr2vr.w VX3, t4, 3 + vstelm.w VX2, YY, 0, 0 + add.d YY, YY, INCY + vstelm.w VX2, YY, 0, 1 + add.d YY, YY, INCY + vstelm.w VX2, YY, 0, 2 + add.d YY, YY, INCY + vstelm.w VX2, YY, 0, 3 + add.d YY, YY, INCY + vfmul.s VX1, VX1, VXA + vfmadd.s VX3, VX3, VXB, VX1 + addi.d I, I, -1 + vstelm.w VX3, YY, 0, 0 + add.d YY, YY, INCY + vstelm.w VX3, YY, 0, 1 + add.d YY, YY, INCY + vstelm.w VX3, YY, 0, 2 + add.d YY, YY, INCY + vstelm.w VX3, YY, 0, 3 + add.d YY, YY, INCY + addi.d X, X, 8 * SIZE + blt $r0, I, .L121 + b .L997 + .align 3 + +.L122: // ALPHA!=0 BETA==0 + vld VX0, X, 0 * SIZE + vld VX1, X, 4 * SIZE + vfmul.s VX0, VX0, VXA + vfmul.s VX1, VX1, VXA + vstelm.w VX0, YY, 0, 0 + add.d YY, YY, INCY + vstelm.w VX0, YY, 0, 1 + add.d YY, YY, INCY + vstelm.w VX0, YY, 0, 2 + add.d YY, YY, INCY + vstelm.w VX0, YY, 0, 3 + add.d YY, YY, INCY + vstelm.w VX1, YY, 0, 0 + add.d YY, YY, INCY + vstelm.w VX1, YY, 0, 1 + add.d YY, YY, INCY + vstelm.w VX1, YY, 0, 2 + add.d YY, YY, INCY + vstelm.w VX1, YY, 0, 3 + add.d YY, YY, INCY + addi.d X, X, 8 * SIZE + addi.d I, I, -1 + blt $r0, I, .L122 + b .L997 + .align 3 + +.L123: // ALPHA==0 BETA!=0 + ld.w t1, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t2, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t3, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t4, Y, 0 * SIZE + vinsgr2vr.w VX2, t1, 0 + vinsgr2vr.w VX2, t2, 1 + vinsgr2vr.w VX2, t3, 2 + vinsgr2vr.w VX2, t4, 3 + add.d Y, Y, INCY + vfmul.s VX2, VX2, VXB + ld.w t1, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t2, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t3, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t4, Y, 0 * SIZE + add.d Y, Y, INCY + vinsgr2vr.w VX3, t1, 0 + vinsgr2vr.w VX3, t2, 1 + vinsgr2vr.w VX3, t3, 2 + vinsgr2vr.w VX3, t4, 3 + vstelm.w VX2, YY, 0, 0 + add.d YY, YY, INCY + vstelm.w VX2, YY, 0, 1 + add.d YY, YY, INCY + vstelm.w VX2, YY, 0, 2 + add.d YY, YY, INCY + vstelm.w VX2, YY, 0, 3 + add.d YY, YY, INCY + vfmul.s VX3, VX3, VXB + addi.d I, I, -1 + vstelm.w VX3, YY, 0, 0 + add.d YY, YY, INCY + vstelm.w VX3, YY, 0, 1 + add.d YY, YY, INCY + vstelm.w VX3, YY, 0, 2 + add.d YY, YY, INCY + vstelm.w VX3, YY, 0, 3 + add.d YY, YY, INCY + blt $r0, I, .L123 + b .L997 + .align 3 + +.L124: // ALPHA==0 BETA==0 + vstelm.w VXZ, YY, 0, 0 + add.d YY, YY, INCY + vstelm.w VXZ, YY, 0, 1 + add.d YY, YY, INCY + vstelm.w VXZ, YY, 0, 2 + add.d YY, YY, INCY + vstelm.w VXZ, YY, 0, 3 + add.d YY, YY, INCY + vstelm.w VXZ, YY, 0, 0 + add.d YY, YY, INCY + vstelm.w VXZ, YY, 0, 1 + add.d YY, YY, INCY + vstelm.w VXZ, YY, 0, 2 + add.d YY, YY, INCY + vstelm.w VXZ, YY, 0, 3 + add.d YY, YY, INCY + addi.d I, I, -1 + blt $r0, I, .L124 + b .L997 + .align 3 + +.L21:// INCX!=1 and INCY==1 + bge $r0, I, .L997 + fcmp.ceq.s $fcc0, ALPHA, a1 + bcnez $fcc0, .L210 + fcmp.ceq.s $fcc0, BETA, a1 + bcnez $fcc0, .L212 // ALPHA!=0 BETA==0 + b .L211 // ALPHA!=0 BETA!=0 + .align 3 + +.L210: + fcmp.ceq.s $fcc0, BETA, a1 + bcnez $fcc0, .L214 // ALPHA==0 BETA==0 + b .L213 // ALPHA==0 BETA!=0 + .align 3 + +.L211: // ALPHA!=0 BETA!=0 + vld VX2, Y, 0 * SIZE + ld.w t1, X, 0 * SIZE + add.d X, X, INCX + ld.w t2, X, 0 * SIZE + add.d X, X, INCX + ld.w t3, X, 0 * SIZE + add.d X, X, INCX + ld.w t4, X, 0 * SIZE + vinsgr2vr.w VX0, t1, 0 + vinsgr2vr.w VX0, t2, 1 + vinsgr2vr.w VX0, t3, 2 + vinsgr2vr.w VX0, t4, 3 + add.d X, X, INCX + vfmul.s VX0, VXA, VX0 + vld VX3, Y, 4 * SIZE + vfmadd.s VX2, VX2, VXB, VX0 + ld.w t1, X, 0 * SIZE + add.d X, X, INCX + ld.w t2, X, 0 * SIZE + add.d X, X, INCX + ld.w t3, X, 0 * SIZE + add.d X, X, INCX + ld.w t4, X, 0 * SIZE + add.d X, X, INCX + vinsgr2vr.w VX1, t1, 0 + vinsgr2vr.w VX1, t2, 1 + vinsgr2vr.w VX1, t3, 2 + vinsgr2vr.w VX1, t4, 3 + vst VX2, Y, 0 * SIZE + vfmul.s VX1, VX1, VXA + vfmadd.s VX3, VX3, VXB, VX1 + addi.d I, I, -1 + vst VX3, Y, 4 * SIZE + addi.d Y, Y, 8 * SIZE + blt $r0, I, .L211 + b .L997 + .align 3 + +.L212: // ALPHA!=0 BETA==0 + ld.w t1, X, 0 * SIZE + add.d X, X, INCX + ld.w t2, X, 0 * SIZE + add.d X, X, INCX + ld.w t3, X, 0 * SIZE + add.d X, X, INCX + ld.w t4, X, 0 * SIZE + vinsgr2vr.w VX0, t1, 0 + vinsgr2vr.w VX0, t2, 1 + vinsgr2vr.w VX0, t3, 2 + vinsgr2vr.w VX0, t4, 3 + add.d X, X, INCX + vfmul.s VX0, VXA, VX0 + ld.w t1, X, 0 * SIZE + add.d X, X, INCX + ld.w t2, X, 0 * SIZE + add.d X, X, INCX + ld.w t3, X, 0 * SIZE + add.d X, X, INCX + ld.w t4, X, 0 * SIZE + add.d X, X, INCX + vinsgr2vr.w VX1, t1, 0 + vinsgr2vr.w VX1, t2, 1 + vinsgr2vr.w VX1, t3, 2 + vinsgr2vr.w VX1, t4, 3 + vst VX0, Y, 0 * SIZE + vfmul.s VX1, VX1, VXA + addi.d I, I, -1 + vst VX1, Y, 4 * SIZE + addi.d Y, Y, 8 * SIZE + blt $r0, I, .L212 + b .L997 + .align 3 + +.L213: // ALPHA==0 BETA!=0 + vld VX2, Y, 0 * SIZE + vld VX3, Y, 4 * SIZE + vfmul.s VX2, VX2, VXB + vfmul.s VX3, VX3, VXB + vst VX2, Y, 0 * SIZE + vst VX3, Y, 4 * SIZE + addi.d Y, Y, 8 * SIZE + addi.d I, I, -1 + blt $r0, I, .L213 + b .L997 + .align 3 + +.L214: // ALPHA==0 BETA==0 + vst VXZ, Y, 0 * SIZE + vst VXZ, Y, 4 * SIZE + addi.d Y, Y, 8 * SIZE + addi.d I, I, -1 + blt $r0, I, .L214 + b .L997 + .align 3 + +.L22: + bge $r0, I, .L997 + move YY, Y + fcmp.ceq.s $fcc0, ALPHA, a1 + bcnez $fcc0, .L220 + fcmp.ceq.s $fcc0, BETA, a1 + bcnez $fcc0, .L222 // ALPHA!=0 BETA==0 + b .L221 // ALPHA!=0 BETA!=0 + .align 3 + +.L220: + fcmp.ceq.s $fcc0, BETA, a1 + bcnez $fcc0, .L224 // ALPHA==0 BETA==0 + b .L223 // ALPHA==0 BETA!=0 + .align 3 + +.L221: // ALPHA!=0 BETA!=0 + ld.w t1, X, 0 * SIZE + add.d X, X, INCX + ld.w t2, X, 0 * SIZE + add.d X, X, INCX + ld.w t3, X, 0 * SIZE + add.d X, X, INCX + ld.w t4, X, 0 * SIZE + add.d X, X, INCX + vinsgr2vr.w VX0, t1, 0 + vinsgr2vr.w VX0, t2, 1 + vinsgr2vr.w VX0, t3, 2 + vinsgr2vr.w VX0, t4, 3 + ld.w t1, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t2, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t3, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t4, Y, 0 * SIZE + vinsgr2vr.w VX2, t1, 0 + vinsgr2vr.w VX2, t2, 1 + vinsgr2vr.w VX2, t3, 2 + vinsgr2vr.w VX2, t4, 3 + add.d Y, Y, INCY + vfmul.s VX0, VX0, VXA + ld.w t1, X, 0 * SIZE + add.d X, X, INCX + ld.w t2, X, 0 * SIZE + add.d X, X, INCX + ld.w t3, X, 0 * SIZE + add.d X, X, INCX + ld.w t4, X, 0 * SIZE + add.d X, X, INCX + vfmadd.s VX2, VX2, VXB, VX0 + vinsgr2vr.w VX1, t1, 0 + vinsgr2vr.w VX1, t2, 1 + vinsgr2vr.w VX1, t3, 2 + vinsgr2vr.w VX1, t4, 3 + vstelm.w VX2, YY, 0, 0 + add.d YY, YY, INCY + vstelm.w VX2, YY, 0, 1 + add.d YY, YY, INCY + vstelm.w VX2, YY, 0, 2 + add.d YY, YY, INCY + vstelm.w VX2, YY, 0, 3 + add.d YY, YY, INCY + ld.w t1, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t2, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t3, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t4, Y, 0 * SIZE + vinsgr2vr.w VX3, t1, 0 + vinsgr2vr.w VX3, t2, 1 + vinsgr2vr.w VX3, t3, 2 + vinsgr2vr.w VX3, t4, 3 + add.d Y, Y, INCY + vfmul.s VX1, VX1, VXA + addi.d I, I, -1 + vfmadd.s VX3, VX3, VXB, VX1 + vstelm.w VX3, YY, 0, 0 + add.d YY, YY, INCY + vstelm.w VX3, YY, 0, 1 + add.d YY, YY, INCY + vstelm.w VX3, YY, 0, 2 + add.d YY, YY, INCY + vstelm.w VX3, YY, 0, 3 + add.d YY, YY, INCY + blt $r0, I, .L221 + b .L997 + .align 3 + +.L222: // ALPHA!=0 BETA==0 + ld.w t1, X, 0 * SIZE + add.d X, X, INCX + ld.w t2, X, 0 * SIZE + add.d X, X, INCX + ld.w t3, X, 0 * SIZE + add.d X, X, INCX + ld.w t4, X, 0 * SIZE + vinsgr2vr.w VX0, t1, 0 + vinsgr2vr.w VX0, t2, 1 + vinsgr2vr.w VX0, t3, 2 + vinsgr2vr.w VX0, t4, 3 + add.d X, X, INCX + vfmul.s VX0, VX0, VXA + ld.w t1, X, 0 * SIZE + add.d X, X, INCX + ld.w t2, X, 0 * SIZE + add.d X, X, INCX + ld.w t3, X, 0 * SIZE + add.d X, X, INCX + ld.w t4, X, 0 * SIZE + add.d X, X, INCX + vinsgr2vr.w VX1, t1, 0 + vinsgr2vr.w VX1, t2, 1 + vinsgr2vr.w VX1, t3, 2 + vinsgr2vr.w VX1, t4, 3 + vstelm.w VX0, YY, 0, 0 + add.d YY, YY, INCY + vstelm.w VX0, YY, 0, 1 + add.d YY, YY, INCY + vstelm.w VX0, YY, 0, 2 + add.d YY, YY, INCY + vstelm.w VX0, YY, 0, 3 + add.d YY, YY, INCY + vfmul.s VX1, VX1, VXA + addi.d I, I, -1 + vstelm.w VX1, YY, 0, 0 + add.d YY, YY, INCY + vstelm.w VX1, YY, 0, 1 + add.d YY, YY, INCY + vstelm.w VX1, YY, 0, 2 + add.d YY, YY, INCY + vstelm.w VX1, YY, 0, 3 + add.d YY, YY, INCY + blt $r0, I, .L222 + b .L997 + .align 3 + +.L223: // ALPHA==0 BETA!=0 + ld.w t1, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t2, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t3, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t4, Y, 0 * SIZE + vinsgr2vr.w VX2, t1, 0 + vinsgr2vr.w VX2, t2, 1 + vinsgr2vr.w VX2, t3, 2 + vinsgr2vr.w VX2, t4, 3 + add.d Y, Y, INCY + vfmul.s VX2, VX2, VXB + ld.w t1, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t2, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t3, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t4, Y, 0 * SIZE + add.d Y, Y, INCY + vinsgr2vr.w VX3, t1, 0 + vinsgr2vr.w VX3, t2, 1 + vinsgr2vr.w VX3, t3, 2 + vinsgr2vr.w VX3, t4, 3 + vstelm.w VX2, YY, 0, 0 + add.d YY, YY, INCY + vstelm.w VX2, YY, 0, 1 + add.d YY, YY, INCY + vstelm.w VX2, YY, 0, 2 + add.d YY, YY, INCY + vstelm.w VX2, YY, 0, 3 + add.d YY, YY, INCY + vfmul.s VX3, VX3, VXB + addi.d I, I, -1 + vstelm.w VX3, YY, 0, 0 + add.d YY, YY, INCY + vstelm.w VX3, YY, 0, 1 + add.d YY, YY, INCY + vstelm.w VX3, YY, 0, 2 + add.d YY, YY, INCY + vstelm.w VX3, YY, 0, 3 + add.d YY, YY, INCY + blt $r0, I, .L223 + b .L997 + .align 3 + +.L224: // ALPHA==0 BETA==0 + vstelm.w VXZ, YY, 0, 0 + add.d YY, YY, INCY + vstelm.w VXZ, YY, 0, 1 + add.d YY, YY, INCY + vstelm.w VXZ, YY, 0, 2 + add.d YY, YY, INCY + vstelm.w VXZ, YY, 0, 3 + add.d YY, YY, INCY + vstelm.w VXZ, YY, 0, 0 + add.d YY, YY, INCY + vstelm.w VXZ, YY, 0, 1 + add.d YY, YY, INCY + vstelm.w VXZ, YY, 0, 2 + add.d YY, YY, INCY + vstelm.w VXZ, YY, 0, 3 + add.d YY, YY, INCY + addi.d I, I, -1 + blt $r0, I, .L224 + b .L997 + .align 3 + +.L997: + andi I, N, 7 + bge $r0, I, .L999 + .align 3 + +.L998: + fld.s $f12, X, 0 * SIZE + fld.s $f13, Y, 0 * SIZE + addi.d I, I, -1 + fmul.s $f12, $f12, ALPHA + fmadd.s $f13, $f13, BETA, $f12 + fst.s $f13, Y, 0 * SIZE + add.d X, X, INCX + add.d Y, Y, INCY + blt $r0, I, .L998 + .align 3 + +.L999: + move $r4, $r12 + jirl $r0, $r1, 0x0 + .align 3 + + EPILOGUE diff --git a/kernel/loongarch64/saxpy_lasx.S b/kernel/loongarch64/saxpy_lasx.S new file mode 100644 index 000000000..609e26328 --- /dev/null +++ b/kernel/loongarch64/saxpy_lasx.S @@ -0,0 +1,323 @@ +#define ASSEMBLER + +#include "common.h" +#define N $r4 +#define XX $r5 +#define YY $r6 +#define ALPHA $f0 +#define X $r7 +#define INCX $r8 +#define Y $r9 +#define INCY $r10 + +#define I $r12 +#define TEMP $r13 +#define t1 $r14 +#define t2 $r16 +#define t3 $r15 +#define t4 $r17 +#define a1 $f12 +#define a2 $f13 +#define a3 $f14 +#define a4 $f15 +#define b1 $f16 +#define b2 $f17 +#define b3 $f18 +#define b4 $f19 +#define VX0 $xr8 +#define VX1 $xr20 +#define VX2 $xr21 +#define VX3 $xr22 +#define VXA $xr23 + + PROLOGUE + + bge $r0, N, .L999 + li.d TEMP, 1 + movgr2fr.d a1, $r0 + ffint.s.l a1, a1 + movgr2fr.d a2, TEMP + ffint.s.l a2, a2 + fcmp.ceq.s $fcc0, ALPHA, a1 + bcnez $fcc0, .L999 + slli.d TEMP, TEMP, BASE_SHIFT + slli.d INCX, INCX, BASE_SHIFT + slli.d INCY, INCY, BASE_SHIFT + movfr2gr.s t1, ALPHA + xvreplgr2vr.w VXA, t1 + + srai.d I, N, 3 + bne INCX, TEMP, .L20 + bne INCY, TEMP, .L12 // INCX==1 and INCY!=1 + b .L11 // INCX==1 and INCY==1 +.L20: + bne INCY, TEMP, .L22 // INCX!=1 and INCY!=1 + b .L21 // INCX!=1 and INCY==1 + +.L11: + bge $r0, I, .L113 + fcmp.ceq.s $fcc0, ALPHA, a2 + bceqz $fcc0, .L112 + .align 3 + +.L111: + xvld VX0, X, 0 * SIZE + xvld VX2, Y, 0 * SIZE + addi.d I, I, -1 + xvfadd.s VX2, VX0, VX2 + xvst VX2, Y, 0 * SIZE + addi.d X, X, 8 * SIZE + addi.d Y, Y, 8 * SIZE + blt $r0, I, .L111 + b .L113 + .align 3 + +.L112: + xvld VX0, X, 0 * SIZE + xvld VX2, Y, 0 * SIZE + addi.d I, I, -1 + xvfmadd.s VX2, VX0, VXA, VX2 + xvst VX2, Y, 0 * SIZE + addi.d X, X, 8 * SIZE + addi.d Y, Y, 8 * SIZE + blt $r0, I, .L112 + .align 3 + +.L113: + andi I, N, 7 + bge $r0, I, .L999 + .align 3 + +.L114: + fld.s $f12, X, 0 * SIZE + fld.s $f14, Y, 0 * SIZE + addi.d I, I, -1 + fmadd.s $f14, $f12, $f0, $f14 + fst.s $f14, Y, 0 * SIZE + addi.d X, X, SIZE + addi.d Y, Y, SIZE + blt $r0, I, .L114 + b .L999 + .align 3 + +.L12: // INCX==1 and INCY!=1 + bge $r0, I, .L122 + move YY, Y + .align 3 + +.L121: + xvld VX0, X, 0 * SIZE + ld.w t1, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t2, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t3, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t4, Y, 0 * SIZE + xvinsgr2vr.w VX2, t1, 0 + xvinsgr2vr.w VX2, t2, 1 + xvinsgr2vr.w VX2, t3, 2 + xvinsgr2vr.w VX2, t4, 3 + add.d Y, Y, INCY + ld.w t1, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t2, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t3, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t4, Y, 0 * SIZE + xvinsgr2vr.w VX2, t1, 4 + xvinsgr2vr.w VX2, t2, 5 + xvinsgr2vr.w VX2, t3, 6 + xvinsgr2vr.w VX2, t4, 7 + add.d Y, Y, INCY + xvfmadd.s VX2, VX0, VXA, VX2 + addi.d I, I, -1 + xvstelm.w VX2, YY, 0, 0 + add.d YY, YY, INCY + xvstelm.w VX2, YY, 0, 1 + add.d YY, YY, INCY + xvstelm.w VX2, YY, 0, 2 + add.d YY, YY, INCY + xvstelm.w VX2, YY, 0, 3 + add.d YY, YY, INCY + xvstelm.w VX2, YY, 0, 4 + add.d YY, YY, INCY + xvstelm.w VX2, YY, 0, 5 + add.d YY, YY, INCY + xvstelm.w VX2, YY, 0, 6 + add.d YY, YY, INCY + xvstelm.w VX2, YY, 0, 7 + add.d YY, YY, INCY + addi.d X, X, 8 * SIZE + blt $r0, I, .L121 + .align 3 + +.L122: + andi I, N, 7 + bge $r0, I, .L999 + .align 3 + +.L123: + fld.s $f12, X, 0 * SIZE + fld.s $f14, Y, 0 * SIZE + addi.d I, I, -1 + fmadd.s $f14, $f12, $f0, $f14 + fst.s $f14, Y, 0 * SIZE + addi.d X, X, SIZE + add.d Y, Y, INCY + blt $r0, I, .L123 + b .L999 + .align 3 + +.L21:// INCX!=1 and INCY==1 + bge $r0, I, .L212 + .align 3 + +.L211: + xvld VX2, Y, 0 * SIZE + ld.w t1, X, 0 * SIZE + add.d X, X, INCX + ld.w t2, X, 0 * SIZE + add.d X, X, INCX + ld.w t3, X, 0 * SIZE + add.d X, X, INCX + ld.w t4, X, 0 * SIZE + xvinsgr2vr.w VX0, t1, 0 + xvinsgr2vr.w VX0, t2, 1 + xvinsgr2vr.w VX0, t3, 2 + xvinsgr2vr.w VX0, t4, 3 + add.d X, X, INCX + ld.w t1, X, 0 * SIZE + add.d X, X, INCX + ld.w t2, X, 0 * SIZE + add.d X, X, INCX + ld.w t3, X, 0 * SIZE + add.d X, X, INCX + ld.w t4, X, 0 * SIZE + add.d X, X, INCX + xvinsgr2vr.w VX0, t1, 4 + xvinsgr2vr.w VX0, t2, 5 + xvinsgr2vr.w VX0, t3, 6 + xvinsgr2vr.w VX0, t4, 7 + xvfmadd.s VX2, VX0, VXA, VX2 + addi.d I, I, -1 + xvst VX2, Y, 0 * SIZE + addi.d Y, Y, 8 * SIZE + blt $r0, I, .L211 + .align 3 + +.L212: + andi I, N, 7 + bge $r0, I, .L999 + .align 3 + +.L213: + fld.s $f12, X, 0 * SIZE + fld.s $f14, Y, 0 * SIZE + addi.d I, I, -1 + fmadd.s $f14, $f12, $f0, $f14 + fst.s $f14, Y, 0 * SIZE + add.d X, X, INCX + addi.d Y, Y, SIZE + blt $r0, I, .L213 + b .L999 + .align 3 + +.L22: + bge $r0, I, .L223 + move YY, Y + .align 3 + +.L222: + ld.w t1, X, 0 * SIZE + add.d X, X, INCX + ld.w t2, X, 0 * SIZE + add.d X, X, INCX + ld.w t3, X, 0 * SIZE + add.d X, X, INCX + ld.w t4, X, 0 * SIZE + add.d X, X, INCX + xvinsgr2vr.w VX0, t1, 0 + xvinsgr2vr.w VX0, t2, 1 + xvinsgr2vr.w VX0, t3, 2 + xvinsgr2vr.w VX0, t4, 3 + ld.w t1, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t2, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t3, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t4, Y, 0 * SIZE + add.d Y, Y, INCY + xvinsgr2vr.w VX2, t1, 0 + xvinsgr2vr.w VX2, t2, 1 + xvinsgr2vr.w VX2, t3, 2 + xvinsgr2vr.w VX2, t4, 3 + ld.w t1, X, 0 * SIZE + add.d X, X, INCX + ld.w t2, X, 0 * SIZE + add.d X, X, INCX + ld.w t3, X, 0 * SIZE + add.d X, X, INCX + ld.w t4, X, 0 * SIZE + add.d X, X, INCX + xvinsgr2vr.w VX0, t1, 4 + xvinsgr2vr.w VX0, t2, 5 + xvinsgr2vr.w VX0, t3, 6 + xvinsgr2vr.w VX0, t4, 7 + ld.w t1, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t2, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t3, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t4, Y, 0 * SIZE + xvinsgr2vr.w VX2, t1, 4 + xvinsgr2vr.w VX2, t2, 5 + xvinsgr2vr.w VX2, t3, 6 + xvinsgr2vr.w VX2, t4, 7 + add.d Y, Y, INCY + xvfmadd.s VX2, VX0, VXA, VX2 + addi.d I, I, -1 + xvstelm.w VX2, YY, 0, 0 + add.d YY, YY, INCY + xvstelm.w VX2, YY, 0, 1 + add.d YY, YY, INCY + xvstelm.w VX2, YY, 0, 2 + add.d YY, YY, INCY + xvstelm.w VX2, YY, 0, 3 + add.d YY, YY, INCY + xvstelm.w VX2, YY, 0, 4 + add.d YY, YY, INCY + xvstelm.w VX2, YY, 0, 5 + add.d YY, YY, INCY + xvstelm.w VX2, YY, 0, 6 + add.d YY, YY, INCY + xvstelm.w VX2, YY, 0, 7 + add.d YY, YY, INCY + blt $r0, I, .L222 + .align 3 + +.L223: + andi I, N, 7 + bge $r0, I, .L999 + .align 3 + +.L224: + fld.s $f12, X, 0 * SIZE + fld.s $f14, Y, 0 * SIZE + addi.d I, I, -1 + fmadd.s $f14, $f12, $f0, $f14 + fst.s $f14, Y, 0 * SIZE + add.d X, X, INCX + add.d Y, Y, INCY + blt $r0, I, .L224 + .align 3 + +.L999: + move $r4, $r12 + jirl $r0, $r1, 0x0 + .align 3 + + EPILOGUE \ No newline at end of file diff --git a/kernel/loongarch64/saxpy_lsx.S b/kernel/loongarch64/saxpy_lsx.S new file mode 100644 index 000000000..f47415ed6 --- /dev/null +++ b/kernel/loongarch64/saxpy_lsx.S @@ -0,0 +1,338 @@ +#define ASSEMBLER + +#include "common.h" +#define N $r4 +#define XX $r5 +#define YY $r6 +#define ALPHA $f0 +#define X $r7 +#define INCX $r8 +#define Y $r9 +#define INCY $r10 + +#define I $r12 +#define TEMP $r13 +#define t1 $r14 +#define t2 $r16 +#define t3 $r15 +#define t4 $r17 +#define a1 $f12 +#define a2 $f13 +#define a3 $f14 +#define a4 $f15 +#define b1 $f16 +#define b2 $f17 +#define b3 $f18 +#define b4 $f19 +#define VX0 $vr8 +#define VX1 $vr20 +#define VX2 $vr21 +#define VX3 $vr22 +#define VXA $vr23 + + PROLOGUE + + bge $r0, N, .L999 + li.d TEMP, 1 + movgr2fr.d a1, $r0 + ffint.s.l a1, a1 + movgr2fr.d a2, TEMP + ffint.s.l a2, a2 + fcmp.ceq.s $fcc0, ALPHA, a1 + bcnez $fcc0, .L999 + slli.d TEMP, TEMP, BASE_SHIFT + slli.d INCX, INCX, BASE_SHIFT + slli.d INCY, INCY, BASE_SHIFT + movfr2gr.s t1, ALPHA + vreplgr2vr.w VXA, t1 + + srai.d I, N, 3 + bne INCX, TEMP, .L20 + bne INCY, TEMP, .L12 // INCX==1 and INCY!=1 + b .L11 // INCX==1 and INCY==1 +.L20: + bne INCY, TEMP, .L22 // INCX!=1 and INCY!=1 + b .L21 // INCX!=1 and INCY==1 + +.L11: + bge $r0, I, .L113 + fcmp.ceq.s $fcc0, ALPHA, a2 + bceqz $fcc0, .L112 + .align 3 + +.L111: + vld VX0, X, 0 * SIZE + vld VX2, Y, 0 * SIZE + vld VX1, X, 4 * SIZE + vld VX3, Y, 4 * SIZE + vfadd.s VX2, VX0, VX2 + vfadd.s VX3, VX1, VX3 + vst VX2, Y, 0 * SIZE + vst VX3, Y, 4 * SIZE + addi.d X, X, 8 * SIZE + addi.d Y, Y, 8 * SIZE + addi.d I, I, -1 + blt $r0, I, .L111 + b .L113 + .align 3 + +.L112: + vld VX0, X, 0 * SIZE + vld VX2, Y, 0 * SIZE + vld VX1, X, 4 * SIZE + vld VX3, Y, 4 * SIZE + vfmadd.s VX2, VX0, VXA, VX2 + vfmadd.s VX3, VX1, VXA, VX3 + vst VX2, Y, 0 * SIZE + vst VX3, Y, 4 * SIZE + addi.d X, X, 8 * SIZE + addi.d Y, Y, 8 * SIZE + addi.d I, I, -1 + blt $r0, I, .L112 + b .L113 + .align 3 + +.L113: + andi I, N, 7 + bge $r0, I, .L999 + .align 3 + +.L114: + fld.s $f12, X, 0 * SIZE + fld.s $f14, Y, 0 * SIZE + addi.d I, I, -1 + fmadd.s $f14, $f12, $f0, $f14 + fst.s $f14, Y, 0 * SIZE + addi.d X, X, SIZE + addi.d Y, Y, SIZE + blt $r0, I, .L114 + b .L999 + .align 3 + +.L12: // INCX==1 and INCY!=1 + bge $r0, I, .L122 + move YY, Y + .align 3 + +.L121: + vld VX0, X, 0 * SIZE + ld.w t1, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t2, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t3, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t4, Y, 0 * SIZE + vinsgr2vr.w VX2, t1, 0 + vinsgr2vr.w VX2, t2, 1 + vinsgr2vr.w VX2, t3, 2 + vinsgr2vr.w VX2, t4, 3 + add.d Y, Y, INCY + vfmadd.s VX2, VX0, VXA, VX2 + vld VX1, X, 4 * SIZE + vstelm.w VX2, YY, 0, 0 + add.d YY, YY, INCY + vstelm.w VX2, YY, 0, 1 + add.d YY, YY, INCY + vstelm.w VX2, YY, 0, 2 + add.d YY, YY, INCY + vstelm.w VX2, YY, 0, 3 + add.d YY, YY, INCY + ld.w t1, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t2, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t3, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t4, Y, 0 * SIZE + vinsgr2vr.w VX3, t1, 0 + vinsgr2vr.w VX3, t2, 1 + vinsgr2vr.w VX3, t3, 2 + vinsgr2vr.w VX3, t4, 3 + add.d Y, Y, INCY + vfmadd.s VX3, VX1, VXA, VX3 + addi.d I, I, -1 + vstelm.w VX3, YY, 0, 0 + add.d YY, YY, INCY + vstelm.w VX3, YY, 0, 1 + add.d YY, YY, INCY + vstelm.w VX3, YY, 0, 2 + add.d YY, YY, INCY + vstelm.w VX3, YY, 0, 3 + add.d YY, YY, INCY + addi.d X, X, 8 * SIZE + blt $r0, I, .L121 + .align 3 + +.L122: + andi I, N, 7 + bge $r0, I, .L999 + .align 3 + +.L123: + fld.s $f12, X, 0 * SIZE + fld.s $f14, Y, 0 * SIZE + addi.d I, I, -1 + fmadd.s $f14, $f12, $f0, $f14 + fst.s $f14, Y, 0 * SIZE + addi.d X, X, SIZE + add.d Y, Y, INCY + blt $r0, I, .L123 + b .L999 + .align 3 + +.L21:// INCX!=1 and INCY==1 + bge $r0, I, .L212 + .align 3 + +.L211: + vld VX2, Y, 0 * SIZE + ld.w t1, X, 0 * SIZE + add.d X, X, INCX + ld.w t2, X, 0 * SIZE + add.d X, X, INCX + ld.w t3, X, 0 * SIZE + add.d X, X, INCX + ld.w t4, X, 0 * SIZE + vinsgr2vr.w VX0, t1, 0 + vinsgr2vr.w VX0, t2, 1 + vinsgr2vr.w VX0, t3, 2 + vinsgr2vr.w VX0, t4, 3 + add.d X, X, INCX + vfmadd.s VX2, VX0, VXA, VX2 + vld VX3, Y, 4 * SIZE + vst VX2, Y, 0 * SIZE + ld.w t1, X, 0 * SIZE + add.d X, X, INCX + ld.w t2, X, 0 * SIZE + add.d X, X, INCX + ld.w t3, X, 0 * SIZE + add.d X, X, INCX + ld.w t4, X, 0 * SIZE + vinsgr2vr.w VX1, t1, 0 + vinsgr2vr.w VX1, t2, 1 + vinsgr2vr.w VX1, t3, 2 + vinsgr2vr.w VX1, t4, 3 + add.d X, X, INCX + vfmadd.s VX3, VX1, VXA, VX3 + addi.d I, I, -1 + vst VX3, Y, 4 * SIZE + addi.d Y, Y, 8 * SIZE + blt $r0, I, .L211 + .align 3 + +.L212: + andi I, N, 7 + bge $r0, I, .L999 + .align 3 + +.L213: + fld.s $f12, X, 0 * SIZE + fld.s $f14, Y, 0 * SIZE + addi.d I, I, -1 + fmadd.s $f14, $f12, $f0, $f14 + fst.s $f14, Y, 0 * SIZE + add.d X, X, INCX + addi.d Y, Y, SIZE + blt $r0, I, .L213 + b .L999 + .align 3 + +.L22: + bge $r0, I, .L223 + move YY, Y + .align 3 + +.L222: + ld.w t1, X, 0 * SIZE + add.d X, X, INCX + ld.w t2, X, 0 * SIZE + add.d X, X, INCX + ld.w t3, X, 0 * SIZE + add.d X, X, INCX + ld.w t4, X, 0 * SIZE + vinsgr2vr.w VX0, t1, 0 + vinsgr2vr.w VX0, t2, 1 + vinsgr2vr.w VX0, t3, 2 + vinsgr2vr.w VX0, t4, 3 + add.d X, X, INCX + ld.w t1, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t2, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t3, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t4, Y, 0 * SIZE + vinsgr2vr.w VX2, t1, 0 + vinsgr2vr.w VX2, t2, 1 + vinsgr2vr.w VX2, t3, 2 + vinsgr2vr.w VX2, t4, 3 + add.d Y, Y, INCY + vfmadd.s VX2, VX0, VXA, VX2 + ld.w t1, X, 0 * SIZE + add.d X, X, INCX + ld.w t2, X, 0 * SIZE + add.d X, X, INCX + ld.w t3, X, 0 * SIZE + add.d X, X, INCX + ld.w t4, X, 0 * SIZE + add.d X, X, INCX + vinsgr2vr.w VX1, t1, 0 + vinsgr2vr.w VX1, t2, 1 + vinsgr2vr.w VX1, t3, 2 + vinsgr2vr.w VX1, t4, 3 + vstelm.w VX2, YY, 0, 0 + add.d YY, YY, INCY + vstelm.w VX2, YY, 0, 1 + add.d YY, YY, INCY + vstelm.w VX2, YY, 0, 2 + add.d YY, YY, INCY + vstelm.w VX2, YY, 0, 3 + add.d YY, YY, INCY + ld.w t1, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t2, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t3, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t4, Y, 0 * SIZE + vinsgr2vr.w VX3, t1, 0 + vinsgr2vr.w VX3, t2, 1 + vinsgr2vr.w VX3, t3, 2 + vinsgr2vr.w VX3, t4, 3 + add.d Y, Y, INCY + vfmadd.s VX3, VX1, VXA, VX3 + addi.d I, I, -1 + vstelm.w VX3, YY, 0, 0 + add.d YY, YY, INCY + vstelm.w VX3, YY, 0, 1 + add.d YY, YY, INCY + vstelm.w VX3, YY, 0, 2 + add.d YY, YY, INCY + vstelm.w VX3, YY, 0, 3 + add.d YY, YY, INCY + blt $r0, I, .L222 + .align 3 + +.L223: + andi I, N, 7 + bge $r0, I, .L999 + .align 3 + +.L224: + fld.s $f12, X, 0 * SIZE + fld.s $f14, Y, 0 * SIZE + addi.d I, I, -1 + fmadd.s $f14, $f12, $f0, $f14 + fst.s $f14, Y, 0 * SIZE + add.d X, X, INCX + add.d Y, Y, INCY + blt $r0, I, .L224 + .align 3 + +.L999: + move $r4, $r12 + jirl $r0, $r1, 0x0 + .align 3 + + EPILOGUE From c80e7e27d1b70d6f9cf80bd64bde096d0c3359e3 Mon Sep 17 00:00:00 2001 From: yancheng Date: Thu, 7 Dec 2023 13:08:03 +0800 Subject: [PATCH 55/60] loongarch64: Add optimizations for sum and asum. --- kernel/loongarch64/KERNEL.LOONGSON2K1000 | 6 + kernel/loongarch64/KERNEL.LOONGSON3R5 | 6 + kernel/loongarch64/dasum_lasx.S | 148 +++++++++++++++++++++ kernel/loongarch64/dasum_lsx.S | 158 +++++++++++++++++++++++ kernel/loongarch64/dsum_lasx.S | 125 ++++++++++++++++++ kernel/loongarch64/dsum_lsx.S | 123 ++++++++++++++++++ kernel/loongarch64/sasum_lasx.S | 157 ++++++++++++++++++++++ kernel/loongarch64/sasum_lsx.S | 148 +++++++++++++++++++++ kernel/loongarch64/ssum_lasx.S | 140 ++++++++++++++++++++ kernel/loongarch64/ssum_lsx.S | 125 ++++++++++++++++++ 10 files changed, 1136 insertions(+) create mode 100644 kernel/loongarch64/dasum_lasx.S create mode 100644 kernel/loongarch64/dasum_lsx.S create mode 100644 kernel/loongarch64/dsum_lasx.S create mode 100644 kernel/loongarch64/dsum_lsx.S create mode 100644 kernel/loongarch64/sasum_lasx.S create mode 100644 kernel/loongarch64/sasum_lsx.S create mode 100644 kernel/loongarch64/ssum_lasx.S create mode 100644 kernel/loongarch64/ssum_lsx.S diff --git a/kernel/loongarch64/KERNEL.LOONGSON2K1000 b/kernel/loongarch64/KERNEL.LOONGSON2K1000 index a94303151..5e83e67a4 100644 --- a/kernel/loongarch64/KERNEL.LOONGSON2K1000 +++ b/kernel/loongarch64/KERNEL.LOONGSON2K1000 @@ -43,4 +43,10 @@ DAXPYKERNEL = daxpy_lsx.S SAXPBYKERNEL = saxpby_lsx.S DAXPBYKERNEL = daxpby_lsx.S +SSUMKERNEL = ssum_lsx.S +DSUMKERNEL = dsum_lsx.S + +SASUMKERNEL = sasum_lsx.S +DASUMKERNEL = dasum_lsx.S + endif diff --git a/kernel/loongarch64/KERNEL.LOONGSON3R5 b/kernel/loongarch64/KERNEL.LOONGSON3R5 index 4cfd53058..2cc2edb74 100644 --- a/kernel/loongarch64/KERNEL.LOONGSON3R5 +++ b/kernel/loongarch64/KERNEL.LOONGSON3R5 @@ -43,6 +43,12 @@ DAXPYKERNEL = daxpy_lasx.S SAXPBYKERNEL = saxpby_lasx.S DAXPBYKERNEL = daxpby_lasx.S +SSUMKERNEL = ssum_lasx.S +DSUMKERNEL = dsum_lasx.S + +SASUMKERNEL = sasum_lasx.S +DASUMKERNEL = dasum_lasx.S + DGEMMKERNEL = dgemm_kernel_16x4.S DGEMMINCOPY = dgemm_ncopy_16.S DGEMMITCOPY = dgemm_tcopy_16.S diff --git a/kernel/loongarch64/dasum_lasx.S b/kernel/loongarch64/dasum_lasx.S new file mode 100644 index 000000000..49de98c40 --- /dev/null +++ b/kernel/loongarch64/dasum_lasx.S @@ -0,0 +1,148 @@ +#define ASSEMBLER +#include "common.h" +#define N $r4 +#define X $r5 +#define INCX $r6 +#define I $r17 +#define TEMP $r18 +#define t1 $r15 +#define t2 $r12 +#define t3 $r13 +#define t4 $r14 +#define VX0 $xr12 +#define VX1 $xr13 +#define VX2 $xr14 +#define VX3 $xr15 +#define VT0 $xr23 +#define VT1 $xr22 +#define res1 $xr16 +#define res2 $xr17 +#define res0 $xr18 +#define neg1 $xr19 + + PROLOGUE + xvxor.v res1, res1, res1 + xvxor.v res2, res2, res2 + xvxor.v res0, res0, res0 + bge $r0, N, .L999 + bge $r0, INCX, .L999 + li.d t1, -1 + xvreplgr2vr.d neg1, t1 + xvffint.d.l neg1, neg1 + li.d TEMP, SIZE + slli.d INCX, INCX, BASE_SHIFT + srai.d I, N, 3 + bne INCX, TEMP, .L20 + bge $r0, I, .L13 + .align 3 + +.L11: + xvld VX0, X, 0 * SIZE + xvld VX1, X, 4 * SIZE + xvfmul.d VX2, neg1, VX0 + xvfmul.d VX3, neg1, VX1 + xvfcmp.clt.d VT0, VX0, res0 + xvfcmp.clt.d VT1, VX1, res0 + xvbitsel.v VX0, VX0, VX2, VT0 + xvbitsel.v VX1, VX1, VX3, VT1 + xvfadd.d res2, VX0, VX1 + xvfadd.d res1, res1, res2 + addi.d X, X, 8 * SIZE + addi.d I, I, -1 + blt $r0, I, .L11 + .align 3 + +.L12: + xvpickve.d VX1, res1, 1 + xvpickve.d VX2, res1, 2 + xvpickve.d VX3, res1, 3 + xvfadd.d res1, VX1, res1 + xvfadd.d res1, VX2, res1 + xvfadd.d res1, VX3, res1 + .align 3 + +.L13: + andi I, N, 7 + bge $r0, I, .L999 + .align 3 + +.L14: + fld.d $f12, X, 0 * SIZE + fabs.d $f12, $f12 + fadd.d $f16, $f12, $f16 + addi.d I, I, -1 + addi.d X, X, SIZE + blt $r0, I, .L14 + b .L999 + .align 3 + +.L20: + bge $r0, I, .L23 + .align 3 + +.L21: + ld.d t1, X, 0 * SIZE + add.d X, X, INCX + ld.d t2, X, 0 * SIZE + add.d X, X, INCX + ld.d t3, X, 0 * SIZE + add.d X, X, INCX + ld.d t4, X, 0 * SIZE + add.d X, X, INCX + xvinsgr2vr.d VX0, t1, 0 + xvinsgr2vr.d VX0, t2, 1 + xvinsgr2vr.d VX0, t3, 2 + xvinsgr2vr.d VX0, t4, 3 + ld.d t1, X, 0 * SIZE + add.d X, X, INCX + ld.d t2, X, 0 * SIZE + add.d X, X, INCX + ld.d t3, X, 0 * SIZE + add.d X, X, INCX + ld.d t4, X, 0 * SIZE + add.d X, X, INCX + xvinsgr2vr.d VX1, t1, 0 + xvinsgr2vr.d VX1, t2, 1 + xvinsgr2vr.d VX1, t3, 2 + xvinsgr2vr.d VX1, t4, 3 + xvfmul.d VX2, neg1, VX0 + xvfmul.d VX3, neg1, VX1 + xvfcmp.clt.d VT0, VX0, res0 + xvfcmp.clt.d VT1, VX1, res0 + xvbitsel.v VX0, VX0, VX2, VT0 + xvbitsel.v VX1, VX1, VX3, VT1 + xvfadd.d res2, VX0, VX1 + xvfadd.d res1, res1, res2 + addi.d I, I, -1 + blt $r0, I, .L21 + .align 3 + +.L22: + xvpickve.d VX1, res1, 1 + xvpickve.d VX2, res1, 2 + xvpickve.d VX3, res1, 3 + xvfadd.d res1, VX1, res1 + xvfadd.d res1, VX2, res1 + xvfadd.d res1, VX3, res1 + .align 3 + +.L23: + andi I, N, 7 + bge $r0, I, .L999 + .align 3 + +.L24: + fld.d $f12, X, 0 * SIZE + fabs.d $f12, $f12 + fadd.d $f16, $f12, $f16 + addi.d I, I, -1 + add.d X, X, INCX + blt $r0, I, .L24 + .align 3 + +.L999: + fmov.d $f0, $f16 + jirl $r0, $r1, 0x0 + .align 3 + + EPILOGUE \ No newline at end of file diff --git a/kernel/loongarch64/dasum_lsx.S b/kernel/loongarch64/dasum_lsx.S new file mode 100644 index 000000000..94750815e --- /dev/null +++ b/kernel/loongarch64/dasum_lsx.S @@ -0,0 +1,158 @@ +#define ASSEMBLER +#include "common.h" +#define N $r4 +#define X $r5 +#define INCX $r6 +#define I $r17 +#define TEMP $r18 +#define t1 $r15 +#define t2 $r12 +#define t3 $r13 +#define t4 $r14 +#define VX0 $vr12 +#define VX1 $vr13 +#define VX2 $vr14 +#define VX3 $vr15 +#define VT0 $vr23 +#define VT1 $vr22 +#define res1 $vr16 +#define res2 $vr17 +#define res0 $vr18 +#define neg1 $vr19 + + PROLOGUE + vxor.v res1, res1, res1 + vxor.v res2, res2, res2 + vxor.v res0, res0, res0 + bge $r0, N, .L999 + bge $r0, INCX, .L999 + li.d t1, -1 + vreplgr2vr.d neg1, t1 + vffint.d.l neg1, neg1 + li.d TEMP, SIZE + slli.d INCX, INCX, BASE_SHIFT + srai.d I, N, 3 + bne INCX, TEMP, .L20 + bge $r0, I, .L13 + .align 3 + +.L11: + vld VX0, X, 0 * SIZE + vld VX1, X, 2 * SIZE + vfmul.d VX2, neg1, VX0 + vfmul.d VX3, neg1, VX1 + vfcmp.clt.d VT0, VX0, res0 + vfcmp.clt.d VT1, VX1, res0 + vbitsel.v VX0, VX0, VX2, VT0 + vbitsel.v VX1, VX1, VX3, VT1 + vfadd.d res2, VX0, VX1 + vfadd.d res1, res1, res2 + vld VX0, X, 4 * SIZE + vld VX1, X, 6 * SIZE + vfmul.d VX2, neg1, VX0 + vfmul.d VX3, neg1, VX1 + vfcmp.clt.d VT0, VX0, res0 + vfcmp.clt.d VT1, VX1, res0 + vbitsel.v VX0, VX0, VX2, VT0 + vbitsel.v VX1, VX1, VX3, VT1 + vfadd.d res2, VX0, VX1 + vfadd.d res1, res1, res2 + addi.d X, X, 8 * SIZE + addi.d I, I, -1 + blt $r0, I, .L11 + .align 3 + +.L12: + vreplvei.d VX1, res1, 1 + vfadd.d res1, VX1, res1 + .align 3 + +.L13: + andi I, N, 7 + bge $r0, I, .L999 + .align 3 + +.L14: + fld.d $f12, X, 0 * SIZE + fabs.d $f12, $f12 + fadd.d $f16, $f12, $f16 + addi.d I, I, -1 + addi.d X, X, SIZE + blt $r0, I, .L14 + b .L999 + .align 3 + +.L20: + bge $r0, I, .L23 + .align 3 + +.L21: + ld.d t1, X, 0 * SIZE + add.d X, X, INCX + ld.d t2, X, 0 * SIZE + add.d X, X, INCX + vinsgr2vr.d VX0, t1, 0 + vinsgr2vr.d VX0, t2, 1 + ld.d t1, X, 0 * SIZE + add.d X, X, INCX + ld.d t2, X, 0 * SIZE + vinsgr2vr.d VX1, t1, 0 + vinsgr2vr.d VX1, t2, 1 + add.d X, X, INCX + vfmul.d VX2, neg1, VX0 + vfmul.d VX3, neg1, VX1 + vfcmp.clt.d VT0, VX0, res0 + vfcmp.clt.d VT1, VX1, res0 + vbitsel.v VX0, VX0, VX2, VT0 + vbitsel.v VX1, VX1, VX3, VT1 + vfadd.d res2, VX0, VX1 + vfadd.d res1, res1, res2 + ld.d t3, X, 0 * SIZE + add.d X, X, INCX + ld.d t4, X, 0 * SIZE + add.d X, X, INCX + vinsgr2vr.d VX0, t3, 0 + vinsgr2vr.d VX0, t4, 1 + ld.d t3, X, 0 * SIZE + add.d X, X, INCX + ld.d t4, X, 0 * SIZE + vinsgr2vr.d VX1, t3, 0 + vinsgr2vr.d VX1, t4, 1 + add.d X, X, INCX + vfmul.d VX2, neg1, VX0 + vfmul.d VX3, neg1, VX1 + vfcmp.clt.d VT0, VX0, res0 + vfcmp.clt.d VT1, VX1, res0 + vbitsel.v VX0, VX0, VX2, VT0 + vbitsel.v VX1, VX1, VX3, VT1 + vfadd.d res2, VX0, VX1 + vfadd.d res1, res1, res2 + addi.d I, I, -1 + blt $r0, I, .L21 + .align 3 + +.L22: + vreplvei.d VX1, res1, 1 + vfadd.d res1, VX1, res1 + .align 3 + +.L23: + andi I, N, 7 + bge $r0, I, .L999 + .align 3 + +.L24: + fld.d $f12, X, 0 * SIZE + fabs.d $f12, $f12 + fadd.d $f16, $f12, $f16 + addi.d I, I, -1 + add.d X, X, INCX + blt $r0, I, .L24 + .align 3 + +.L999: + fmov.d $f0, $f16 + jirl $r0, $r1, 0x0 + .align 3 + + EPILOGUE \ No newline at end of file diff --git a/kernel/loongarch64/dsum_lasx.S b/kernel/loongarch64/dsum_lasx.S new file mode 100644 index 000000000..3c51dab60 --- /dev/null +++ b/kernel/loongarch64/dsum_lasx.S @@ -0,0 +1,125 @@ +#define ASSEMBLER +#include "common.h" +#define N $r4 +#define X $r5 +#define INCX $r6 +#define I $r17 +#define TEMP $r18 +#define t1 $r15 +#define t2 $r12 +#define t3 $r13 +#define t4 $r14 +#define VX0 $xr12 +#define VX1 $xr13 +#define VX2 $xr14 +#define VX3 $xr15 +#define res1 $xr16 +#define res2 $xr17 + PROLOGUE + xvxor.v res1, res1, res1 + xvxor.v res2, res2, res2 + bge $r0, N, .L999 + bge $r0, INCX, .L999 + li.d TEMP, SIZE + slli.d INCX, INCX, BASE_SHIFT + srai.d I, N, 3 + bne INCX, TEMP, .L20 + bge $r0, I, .L13 + .align 3 + +.L11: + xvld VX0, X, 0 * SIZE + xvld VX1, X, 4 * SIZE + xvfadd.d res2, VX0, VX1 + xvfadd.d res1, res1, res2 + addi.d X, X, 8 * SIZE + addi.d I, I, -1 + blt $r0, I, .L11 + .align 3 + +.L12: + xvpickve.d VX1, res1, 1 + xvpickve.d VX2, res1, 2 + xvpickve.d VX3, res1, 3 + xvfadd.d res1, VX1, res1 + xvfadd.d res1, VX2, res1 + xvfadd.d res1, VX3, res1 + .align 3 + +.L13: + andi I, N, 7 + bge $r0, I, .L999 + .align 3 + +.L14: + fld.d $f12, X, 0 * SIZE + addi.d I, I, -1 + fadd.d $f16, $f12, $f16 + addi.d X, X, SIZE + blt $r0, I, .L14 + b .L999 + .align 3 + +.L20: + bge $r0, I, .L23 + .align 3 + +.L21: + ld.d t1, X, 0 * SIZE + add.d X, X, INCX + ld.d t2, X, 0 * SIZE + add.d X, X, INCX + ld.d t3, X, 0 * SIZE + add.d X, X, INCX + ld.d t4, X, 0 * SIZE + add.d X, X, INCX + xvinsgr2vr.d VX0, t1, 0 + xvinsgr2vr.d VX0, t2, 1 + xvinsgr2vr.d VX0, t3, 2 + xvinsgr2vr.d VX0, t4, 3 + ld.d t1, X, 0 * SIZE + add.d X, X, INCX + ld.d t2, X, 0 * SIZE + add.d X, X, INCX + ld.d t3, X, 0 * SIZE + add.d X, X, INCX + ld.d t4, X, 0 * SIZE + add.d X, X, INCX + xvinsgr2vr.d VX1, t1, 0 + xvinsgr2vr.d VX1, t2, 1 + xvinsgr2vr.d VX1, t3, 2 + xvinsgr2vr.d VX1, t4, 3 + xvfadd.d res2, VX0, VX1 + xvfadd.d res1, res1, res2 + addi.d I, I, -1 + blt $r0, I, .L21 + .align 3 + +.L22: + xvpickve.d VX1, res1, 1 + xvpickve.d VX2, res1, 2 + xvpickve.d VX3, res1, 3 + xvfadd.d res1, VX1, res1 + xvfadd.d res1, VX2, res1 + xvfadd.d res1, VX3, res1 + .align 3 + +.L23: + andi I, N, 7 + bge $r0, I, .L999 + .align 3 + +.L24: + fld.d $f12, X, 0 * SIZE + fadd.d $f16, $f12, $f16 + addi.d I, I, -1 + add.d X, X, INCX + blt $r0, I, .L24 + .align 3 + +.L999: + fmov.d $f0, $f16 + jirl $r0, $r1, 0x0 + .align 3 + + EPILOGUE diff --git a/kernel/loongarch64/dsum_lsx.S b/kernel/loongarch64/dsum_lsx.S new file mode 100644 index 000000000..402d087df --- /dev/null +++ b/kernel/loongarch64/dsum_lsx.S @@ -0,0 +1,123 @@ +#define ASSEMBLER +#include "common.h" +#define N $r4 +#define X $r5 +#define INCX $r6 +#define I $r17 +#define TEMP $r18 +#define t1 $r15 +#define t2 $r12 +#define t3 $r13 +#define t4 $r14 +#define VX0 $vr12 +#define VX1 $vr13 +#define VX2 $vr14 +#define VX3 $vr15 +#define res1 $vr16 +#define res2 $vr17 + PROLOGUE + vxor.v res1, res1, res1 + vxor.v res2, res2, res2 + bge $r0, N, .L999 + bge $r0, INCX, .L999 + li.d TEMP, SIZE + slli.d INCX, INCX, BASE_SHIFT + srai.d I, N, 3 + bne INCX, TEMP, .L20 + bge $r0, I, .L13 + .align 3 + +.L11: + vld VX0, X, 0 * SIZE + vld VX1, X, 2 * SIZE + vfadd.d res2, VX0, VX1 + vfadd.d res1, res1, res2 + vld VX0, X, 4 * SIZE + vld VX1, X, 6 * SIZE + vfadd.d res2, VX0, VX1 + vfadd.d res1, res1, res2 + addi.d X, X, 8 * SIZE + addi.d I, I, -1 + blt $r0, I, .L11 + .align 3 + +.L12: + vreplvei.d VX1, res1, 1 + vfadd.d res1, VX1, res1 + .align 3 + +.L13: + andi I, N, 7 + bge $r0, I, .L999 + .align 3 + +.L14: + fld.d $f12, X, 0 * SIZE + fadd.d $f16, $f12, $f16 + addi.d I, I, -1 + addi.d X, X, SIZE + blt $r0, I, .L14 + b .L999 + .align 3 + +.L20: + bge $r0, I, .L23 + .align 3 + +.L21: + ld.d t1, X, 0 * SIZE + add.d X, X, INCX + ld.d t2, X, 0 * SIZE + add.d X, X, INCX + vinsgr2vr.d VX0, t1, 0 + vinsgr2vr.d VX0, t2, 1 + ld.d t1, X, 0 * SIZE + add.d X, X, INCX + ld.d t2, X, 0 * SIZE + vinsgr2vr.d VX1, t1, 0 + vinsgr2vr.d VX1, t2, 1 + add.d X, X, INCX + vfadd.d res2, VX0, VX1 + vfadd.d res1, res1, res2 + ld.d t3, X, 0 * SIZE + add.d X, X, INCX + ld.d t4, X, 0 * SIZE + add.d X, X, INCX + vinsgr2vr.d VX0, t3, 0 + vinsgr2vr.d VX0, t4, 1 + ld.d t3, X, 0 * SIZE + add.d X, X, INCX + ld.d t4, X, 0 * SIZE + vinsgr2vr.d VX1, t3, 0 + vinsgr2vr.d VX1, t4, 1 + add.d X, X, INCX + vfadd.d res2, VX0, VX1 + vfadd.d res1, res1, res2 + addi.d I, I, -1 + blt $r0, I, .L21 + .align 3 + +.L22: + vreplvei.d VX1, res1, 1 + vfadd.d res1, VX1, res1 + .align 3 + +.L23: + andi I, N, 7 + bge $r0, I, .L999 + .align 3 + +.L24: + fld.d $f12, X, 0 * SIZE + fadd.d $f16, $f12, $f16 + addi.d I, I, -1 + add.d X, X, INCX + blt $r0, I, .L24 + .align 3 + +.L999: + fmov.d $f0, $f16 + jirl $r0, $r1, 0x0 + .align 3 + + EPILOGUE diff --git a/kernel/loongarch64/sasum_lasx.S b/kernel/loongarch64/sasum_lasx.S new file mode 100644 index 000000000..a452701aa --- /dev/null +++ b/kernel/loongarch64/sasum_lasx.S @@ -0,0 +1,157 @@ +#define ASSEMBLER +#include "common.h" +#define N $r4 +#define X $r5 +#define INCX $r6 +#define I $r17 +#define TEMP $r18 +#define t1 $r15 +#define t2 $r12 +#define t3 $r13 +#define t4 $r14 +#define VX0 $xr12 +#define VX1 $xr13 +#define VX2 $xr14 +#define VX3 $xr15 +#define VT0 $xr23 +#define VT1 $xr22 +#define res1 $xr16 +#define res2 $xr17 +#define res0 $xr18 +#define neg1 $xr19 + + PROLOGUE + xvxor.v res1, res1, res1 + xvxor.v res2, res2, res2 + xvxor.v res0, res0, res0 + bge $r0, N, .L999 + bge $r0, INCX, .L999 + li.w t1, -1 + xvreplgr2vr.w neg1, t1 + xvffint.s.w neg1, neg1 + li.d TEMP, SIZE + slli.d INCX, INCX, BASE_SHIFT + srai.d I, N, 3 + bne INCX, TEMP, .L20 + bge $r0, I, .L13 + .align 3 + +.L11: + xvld VX0, X, 0 * SIZE + xvfmul.s VX2, neg1, VX0 + xvfcmp.clt.s VT0, VX0, res0 + xvbitsel.v VX0, VX0, VX2, VT0 + xvfadd.s res1, VX0, res1 + addi.d X, X, 8 * SIZE + addi.d I, I, -1 + blt $r0, I, .L11 + .align 3 + +.L12: + xvfadd.s res2, res1, res2 + xvpickve.w VX1, res1, 1 + xvpickve.w VX2, res1, 2 + xvpickve.w VX3, res1, 3 + xvfadd.s res1, VX1, res1 + xvfadd.s res1, VX2, res1 + xvfadd.s res1, VX3, res1 + xvpickve.w VX0, res2, 4 + xvpickve.w VX1, res2, 5 + xvpickve.w VX2, res2, 6 + xvpickve.w VX3, res2, 7 + xvfadd.s res1, VX0, res1 + xvfadd.s res1, VX1, res1 + xvfadd.s res1, VX2, res1 + xvfadd.s res1, VX2, res1 + .align 3 + +.L13: + andi I, N, 7 + bge $r0, I, .L999 + .align 3 + +.L14: + fld.s $f12, X, 0 * SIZE + fabs.s $f12, $f12 + fadd.s $f16, $f12, $f16 + addi.d I, I, -1 + addi.d X, X, SIZE + blt $r0, I, .L14 + b .L999 + .align 3 + +.L20: + bge $r0, I, .L23 + .align 3 + +.L21: + ld.w t1, X, 0 * SIZE + add.d X, X, INCX + ld.w t2, X, 0 * SIZE + add.d X, X, INCX + ld.w t3, X, 0 * SIZE + add.d X, X, INCX + ld.w t4, X, 0 * SIZE + add.d X, X, INCX + xvinsgr2vr.w VX0, t1, 0 + xvinsgr2vr.w VX0, t2, 1 + xvinsgr2vr.w VX0, t3, 2 + xvinsgr2vr.w VX0, t4, 3 + ld.w t1, X, 0 * SIZE + add.d X, X, INCX + ld.w t2, X, 0 * SIZE + add.d X, X, INCX + ld.w t3, X, 0 * SIZE + add.d X, X, INCX + ld.w t4, X, 0 * SIZE + add.d X, X, INCX + xvinsgr2vr.w VX0, t1, 4 + xvinsgr2vr.w VX0, t2, 5 + xvinsgr2vr.w VX0, t3, 6 + xvinsgr2vr.w VX0, t4, 7 + xvfmul.s VX2, neg1, VX0 + xvfcmp.clt.s VT0, VX0, res0 + xvbitsel.v VX0, VX0, VX2, VT0 + xvfadd.s res1, VX0, res1 + addi.d I, I, -1 + blt $r0, I, .L21 + .align 3 + +.L22: + xvfadd.s res2, res1, res2 + xvpickve.w VX1, res1, 1 + xvpickve.w VX2, res1, 2 + xvpickve.w VX3, res1, 3 + xvfadd.s res1, VX1, res1 + xvfadd.s res1, VX2, res1 + xvfadd.s res1, VX3, res1 + xvpickve.w VX0, res2, 4 + xvpickve.w VX1, res2, 5 + xvpickve.w VX2, res2, 6 + xvpickve.w VX3, res2, 7 + xvfadd.s res1, VX0, res1 + xvfadd.s res1, VX1, res1 + xvfadd.s res1, VX2, res1 + xvfadd.s res1, VX2, res1 + .align 3 + +.L23: + andi I, N, 7 + bge $r0, I, .L999 + .align 3 + +.L24: + fld.s $f12, X, 0 * SIZE + fabs.s $f12, $f12 + fadd.s $f16, $f12, $f16 + addi.d I, I, -1 + add.d X, X, INCX + blt $r0, I, .L24 + .align 3 + +.L999: + fmov.s $f0, $f16 + jirl $r0, $r1, 0x0 + .align 3 + + EPILOGUE \ No newline at end of file diff --git a/kernel/loongarch64/sasum_lsx.S b/kernel/loongarch64/sasum_lsx.S new file mode 100644 index 000000000..87026a144 --- /dev/null +++ b/kernel/loongarch64/sasum_lsx.S @@ -0,0 +1,148 @@ +#define ASSEMBLER +#include "common.h" +#define N $r4 +#define X $r5 +#define INCX $r6 +#define I $r17 +#define TEMP $r18 +#define t1 $r15 +#define t2 $r12 +#define t3 $r13 +#define t4 $r14 +#define VX0 $vr12 +#define VX1 $vr13 +#define VX2 $vr14 +#define VX3 $vr15 +#define VT0 $vr23 +#define VT1 $vr22 +#define res1 $vr16 +#define res2 $vr17 +#define res0 $vr18 +#define neg1 $vr19 + + PROLOGUE + vxor.v res1, res1, res1 + vxor.v res2, res2, res2 + vxor.v res0, res0, res0 + bge $r0, N, .L999 + bge $r0, INCX, .L999 + li.w t1, -1 + vreplgr2vr.w neg1, t1 + vffint.s.w neg1, neg1 + li.d TEMP, SIZE + slli.d INCX, INCX, BASE_SHIFT + srai.d I, N, 3 + bne INCX, TEMP, .L20 + bge $r0, I, .L13 + .align 3 + +.L11: + vld VX0, X, 0 * SIZE + vld VX1, X, 4 * SIZE + vfmul.s VX2, neg1, VX0 + vfmul.s VX3, neg1, VX1 + vfcmp.clt.s VT0, VX0, res0 + vfcmp.clt.s VT1, VX1, res0 + vbitsel.v VX0, VX0, VX2, VT0 + vbitsel.v VX1, VX1, VX3, VT1 + vfadd.s res2, VX0, VX1 + vfadd.s res1, res1, res2 + addi.d X, X, 8 * SIZE + addi.d I, I, -1 + blt $r0, I, .L11 + .align 3 + +.L12: + vreplvei.w VX1, res1, 1 + vreplvei.w VX2, res1, 2 + vreplvei.w VX3, res1, 3 + vfadd.s res1, VX1, res1 + vfadd.s res1, VX2, res1 + vfadd.s res1, VX3, res1 + .align 3 + +.L13: + andi I, N, 7 + bge $r0, I, .L999 + .align 3 + +.L14: + fld.s $f12, X, 0 * SIZE + fabs.s $f12, $f12 + fadd.s $f16, $f12, $f16 + addi.d I, I, -1 + addi.d X, X, SIZE + blt $r0, I, .L14 + b .L999 + .align 3 + +.L20: + bge $r0, I, .L23 + .align 3 + +.L21: + ld.w t1, X, 0 * SIZE + add.d X, X, INCX + ld.w t2, X, 0 * SIZE + add.d X, X, INCX + ld.w t3, X, 0 * SIZE + add.d X, X, INCX + ld.w t4, X, 0 * SIZE + add.d X, X, INCX + vinsgr2vr.w VX0, t1, 0 + vinsgr2vr.w VX0, t2, 1 + vinsgr2vr.w VX0, t3, 2 + vinsgr2vr.w VX0, t4, 3 + ld.w t1, X, 0 * SIZE + add.d X, X, INCX + ld.w t2, X, 0 * SIZE + add.d X, X, INCX + ld.w t3, X, 0 * SIZE + add.d X, X, INCX + ld.w t4, X, 0 * SIZE + add.d X, X, INCX + vinsgr2vr.w VX1, t1, 0 + vinsgr2vr.w VX1, t2, 1 + vinsgr2vr.w VX1, t3, 2 + vinsgr2vr.w VX1, t4, 3 + vfmul.s VX2, neg1, VX0 + vfmul.s VX3, neg1, VX1 + vfcmp.clt.s VT0, VX0, res0 + vfcmp.clt.s VT1, VX1, res0 + vbitsel.v VX0, VX0, VX2, VT0 + vbitsel.v VX1, VX1, VX3, VT1 + vfadd.s res2, VX0, VX1 + vfadd.s res1, res1, res2 + addi.d I, I, -1 + blt $r0, I, .L21 + .align 3 + +.L22: + vreplvei.w VX1, res1, 1 + vreplvei.w VX2, res1, 2 + vreplvei.w VX3, res1, 3 + vfadd.s res1, VX1, res1 + vfadd.s res1, VX2, res1 + vfadd.s res1, VX3, res1 + .align 3 + +.L23: + andi I, N, 7 + bge $r0, I, .L999 + .align 3 + +.L24: + fld.s $f12, X, 0 * SIZE + fabs.s $f12, $f12 + fadd.s $f16, $f12, $f16 + addi.d I, I, -1 + add.d X, X, INCX + blt $r0, I, .L24 + .align 3 + +.L999: + fmov.s $f0, $f16 + jirl $r0, $r1, 0x0 + .align 3 + + EPILOGUE \ No newline at end of file diff --git a/kernel/loongarch64/ssum_lasx.S b/kernel/loongarch64/ssum_lasx.S new file mode 100644 index 000000000..7cf57bc77 --- /dev/null +++ b/kernel/loongarch64/ssum_lasx.S @@ -0,0 +1,140 @@ +#define ASSEMBLER +#include "common.h" +#define N $r4 +#define X $r5 +#define INCX $r6 +#define I $r17 +#define TEMP $r18 +#define t1 $r15 +#define t2 $r12 +#define t3 $r13 +#define t4 $r14 +#define VX0 $xr12 +#define VX1 $xr13 +#define VX2 $xr14 +#define VX3 $xr15 +#define res1 $xr16 +#define res2 $xr17 + PROLOGUE + xvxor.v res1, res1, res1 + xvxor.v res2, res2, res2 + bge $r0, N, .L999 + bge $r0, INCX, .L999 + li.d TEMP, SIZE + slli.d INCX, INCX, BASE_SHIFT + srai.d I, N, 3 + bne INCX, TEMP, .L20 + bge $r0, I, .L13 + .align 3 + +.L11: + xvld VX0, X, 0 * SIZE + xvfadd.s res1, VX0, res1 + addi.d X, X, 8 * SIZE + addi.d I, I, -1 + blt $r0, I, .L11 + .align 3 + +.L12: + xvfadd.s res2, res1, res2 + xvpickve.w VX1, res1, 1 + xvpickve.w VX2, res1, 2 + xvpickve.w VX3, res1, 3 + xvfadd.s res1, VX1, res1 + xvfadd.s res1, VX2, res1 + xvfadd.s res1, VX3, res1 + xvpickve.w VX0, res2, 4 + xvpickve.w VX1, res2, 5 + xvpickve.w VX2, res2, 6 + xvpickve.w VX3, res2, 7 + xvfadd.s res1, VX0, res1 + xvfadd.s res1, VX1, res1 + xvfadd.s res1, VX2, res1 + xvfadd.s res1, VX2, res1 + .align 3 + +.L13: + andi I, N, 7 + bge $r0, I, .L999 + .align 3 + +.L14: + fld.s $f12, X, 0 * SIZE + fadd.s $f16, $f12, $f16 + addi.d I, I, -1 + addi.d X, X, SIZE + blt $r0, I, .L14 + b .L999 + .align 3 + +.L20: + bge $r0, I, .L23 + .align 3 + +.L21: + ld.w t1, X, 0 * SIZE + add.d X, X, INCX + ld.w t2, X, 0 * SIZE + add.d X, X, INCX + ld.w t3, X, 0 * SIZE + add.d X, X, INCX + ld.w t4, X, 0 * SIZE + add.d X, X, INCX + xvinsgr2vr.w VX0, t1, 0 + xvinsgr2vr.w VX0, t2, 1 + xvinsgr2vr.w VX0, t3, 2 + xvinsgr2vr.w VX0, t4, 3 + ld.w t1, X, 0 * SIZE + add.d X, X, INCX + ld.w t2, X, 0 * SIZE + add.d X, X, INCX + ld.w t3, X, 0 * SIZE + add.d X, X, INCX + ld.w t4, X, 0 * SIZE + add.d X, X, INCX + xvinsgr2vr.w VX0, t1, 4 + xvinsgr2vr.w VX0, t2, 5 + xvinsgr2vr.w VX0, t3, 6 + xvinsgr2vr.w VX0, t4, 7 + xvfadd.s res1, VX0, res1 + addi.d I, I, -1 + blt $r0, I, .L21 + .align 3 + +.L22: + xvfadd.s res2, res1, res2 + xvpickve.w VX1, res1, 1 + xvpickve.w VX2, res1, 2 + xvpickve.w VX3, res1, 3 + xvfadd.s res1, VX1, res1 + xvfadd.s res1, VX2, res1 + xvfadd.s res1, VX3, res1 + xvpickve.w VX0, res2, 4 + xvpickve.w VX1, res2, 5 + xvpickve.w VX2, res2, 6 + xvpickve.w VX3, res2, 7 + xvfadd.s res1, VX0, res1 + xvfadd.s res1, VX1, res1 + xvfadd.s res1, VX2, res1 + xvfadd.s res1, VX2, res1 + .align 3 + +.L23: + andi I, N, 7 + bge $r0, I, .L999 + .align 3 + +.L24: + fld.s $f12, X, 0 * SIZE + fadd.s $f16, $f12, $f16 + addi.d I, I, -1 + add.d X, X, INCX + blt $r0, I, .L24 + .align 3 + +.L999: + fmov.s $f0, $f16 + jirl $r0, $r1, 0x0 + .align 3 + + EPILOGUE \ No newline at end of file diff --git a/kernel/loongarch64/ssum_lsx.S b/kernel/loongarch64/ssum_lsx.S new file mode 100644 index 000000000..de63c69e3 --- /dev/null +++ b/kernel/loongarch64/ssum_lsx.S @@ -0,0 +1,125 @@ +#define ASSEMBLER +#include "common.h" +#define N $r4 +#define X $r5 +#define INCX $r6 +#define I $r17 +#define TEMP $r18 +#define t1 $r15 +#define t2 $r12 +#define t3 $r13 +#define t4 $r14 +#define VX0 $vr12 +#define VX1 $vr13 +#define VX2 $vr14 +#define VX3 $vr15 +#define res1 $vr16 +#define res2 $vr17 + PROLOGUE + vxor.v res1, res1, res1 + vxor.v res2, res2, res2 + bge $r0, N, .L999 + bge $r0, INCX, .L999 + li.d TEMP, SIZE + slli.d INCX, INCX, BASE_SHIFT + srai.d I, N, 3 + bne INCX, TEMP, .L20 + bge $r0, I, .L13 + .align 3 + +.L11: + vld VX0, X, 0 * SIZE + vld VX1, X, 4 * SIZE + vfadd.s res2, VX0, VX1 + vfadd.s res1, res1, res2 + addi.d X, X, 8 * SIZE + addi.d I, I, -1 + blt $r0, I, .L11 + .align 3 + +.L12: + vreplvei.w VX1, res1, 1 + vreplvei.w VX2, res1, 2 + vreplvei.w VX3, res1, 3 + vfadd.s res1, VX1, res1 + vfadd.s res1, VX2, res1 + vfadd.s res1, VX3, res1 + .align 3 + +.L13: + andi I, N, 7 + bge $r0, I, .L999 + .align 3 + +.L14: + fld.s $f12, X, 0 * SIZE + fadd.s $f16, $f12, $f16 + addi.d I, I, -1 + addi.d X, X, SIZE + blt $r0, I, .L14 + b .L999 + .align 3 + +.L20: + bge $r0, I, .L23 + .align 3 + +.L21: + ld.w t1, X, 0 * SIZE + add.d X, X, INCX + ld.w t2, X, 0 * SIZE + add.d X, X, INCX + ld.w t3, X, 0 * SIZE + add.d X, X, INCX + ld.w t4, X, 0 * SIZE + add.d X, X, INCX + vinsgr2vr.w VX0, t1, 0 + vinsgr2vr.w VX0, t2, 1 + vinsgr2vr.w VX0, t3, 2 + vinsgr2vr.w VX0, t4, 3 + ld.w t1, X, 0 * SIZE + add.d X, X, INCX + ld.w t2, X, 0 * SIZE + add.d X, X, INCX + ld.w t3, X, 0 * SIZE + add.d X, X, INCX + ld.w t4, X, 0 * SIZE + add.d X, X, INCX + vinsgr2vr.w VX1, t1, 0 + vinsgr2vr.w VX1, t2, 1 + vinsgr2vr.w VX1, t3, 2 + vinsgr2vr.w VX1, t4, 3 + vfadd.s res2, VX0, VX1 + vfadd.s res1, res1, res2 + addi.d I, I, -1 + blt $r0, I, .L21 + .align 3 + +.L22: + vreplvei.w VX1, res1, 1 + vreplvei.w VX2, res1, 2 + vreplvei.w VX3, res1, 3 + vfadd.s res1, VX1, res1 + vfadd.s res1, VX2, res1 + vfadd.s res1, VX3, res1 + .align 3 + +.L23: + andi I, N, 7 + bge $r0, I, .L999 + .align 3 + +.L24: + fld.s $f12, X, 0 * SIZE + fadd.s $f16, $f12, $f16 + addi.d I, I, -1 + add.d X, X, INCX + blt $r0, I, .L24 + .align 3 + +.L999: + fmov.s $f0, $f16 + jirl $r0, $r1, 0x0 + .align 3 + + EPILOGUE \ No newline at end of file From f9b468990e2ca2af5ea3f5848dc23152aa0da5bb Mon Sep 17 00:00:00 2001 From: yancheng Date: Thu, 7 Dec 2023 13:12:29 +0800 Subject: [PATCH 56/60] loongarch64: Add optimizations for rot. --- kernel/loongarch64/KERNEL.LOONGSON2K1000 | 3 + kernel/loongarch64/KERNEL.LOONGSON3R5 | 3 + kernel/loongarch64/drot_lasx.S | 927 +++++++++++++++++++ kernel/loongarch64/drot_lsx.S | 1050 ++++++++++++++++++++++ kernel/loongarch64/srot_lasx.S | 863 ++++++++++++++++++ kernel/loongarch64/srot_lsx.S | 927 +++++++++++++++++++ 6 files changed, 3773 insertions(+) create mode 100644 kernel/loongarch64/drot_lasx.S create mode 100644 kernel/loongarch64/drot_lsx.S create mode 100644 kernel/loongarch64/srot_lasx.S create mode 100644 kernel/loongarch64/srot_lsx.S diff --git a/kernel/loongarch64/KERNEL.LOONGSON2K1000 b/kernel/loongarch64/KERNEL.LOONGSON2K1000 index 5e83e67a4..026ea0d77 100644 --- a/kernel/loongarch64/KERNEL.LOONGSON2K1000 +++ b/kernel/loongarch64/KERNEL.LOONGSON2K1000 @@ -49,4 +49,7 @@ DSUMKERNEL = dsum_lsx.S SASUMKERNEL = sasum_lsx.S DASUMKERNEL = dasum_lsx.S +SROTKERNEL = srot_lsx.S +DROTKERNEL = drot_lsx.S + endif diff --git a/kernel/loongarch64/KERNEL.LOONGSON3R5 b/kernel/loongarch64/KERNEL.LOONGSON3R5 index 2cc2edb74..4905a50a9 100644 --- a/kernel/loongarch64/KERNEL.LOONGSON3R5 +++ b/kernel/loongarch64/KERNEL.LOONGSON3R5 @@ -49,6 +49,9 @@ DSUMKERNEL = dsum_lasx.S SASUMKERNEL = sasum_lasx.S DASUMKERNEL = dasum_lasx.S +SROTKERNEL = srot_lasx.S +DROTKERNEL = drot_lasx.S + DGEMMKERNEL = dgemm_kernel_16x4.S DGEMMINCOPY = dgemm_ncopy_16.S DGEMMITCOPY = dgemm_tcopy_16.S diff --git a/kernel/loongarch64/drot_lasx.S b/kernel/loongarch64/drot_lasx.S new file mode 100644 index 000000000..d3644b780 --- /dev/null +++ b/kernel/loongarch64/drot_lasx.S @@ -0,0 +1,927 @@ +#define ASSEMBLER + +#include "common.h" +#define N $r4 +#define X $r5 +#define INCX $r6 +#define Y $r7 +#define INCY $r8 +#define C $f0 +#define S $f1 + +#define I $r12 +#define TEMP $r13 +#define t1 $r14 +#define t2 $r16 +#define t3 $r15 +#define t4 $r17 +#define XX $r18 +#define YY $r19 +#define a1 $f12 +#define VX0 $xr8 +#define VX1 $xr20 +#define VX2 $xr21 +#define VX3 $xr22 +#define VT0 $xr10 +#define VT1 $xr18 +#define VXC $xr23 +#define VXS $xr9 +#define VXZ $xr19 + + PROLOGUE + + bge $r0, N, .L999 + li.d TEMP, 1 + movgr2fr.d a1, $r0 + ffint.d.l a1, a1 + slli.d TEMP, TEMP, BASE_SHIFT + slli.d INCX, INCX, BASE_SHIFT + slli.d INCY, INCY, BASE_SHIFT + movfr2gr.d t1, C + xvreplgr2vr.d VXC, t1 + movfr2gr.d t2, S + xvreplgr2vr.d VXS, t2 + movfr2gr.d t3, a1 + xvreplgr2vr.d VXZ, t3 + srai.d I, N, 3 + bne INCX, TEMP, .L20 + bne INCY, TEMP, .L12 // INCX==1 and INCY!=1 + b .L11 // INCX==1 and INCY==1 +.L20: + bne INCY, TEMP, .L22 // INCX!=1 and INCY!=1 + b .L21 // INCX!=1 and INCY==1 + +.L11: + bge $r0, I, .L997 + fcmp.ceq.d $fcc0, C, a1 + bcnez $fcc0, .L110 + fcmp.ceq.d $fcc0, S, a1 + bcnez $fcc0, .L112 // C!=0 S==0 + b .L111 // C!=0 S!=0 + .align 3 + +.L110: + fcmp.ceq.d $fcc0, S, a1 + bcnez $fcc0, .L114 // C==0 S==0 + b .L113 // C==0 S!=0 + .align 3 + +.L111: // C!=0 S!=0 + xvld VX0, X, 0 * SIZE + xvld VX2, Y, 0 * SIZE + xvld VX1, X, 4 * SIZE + xvld VX3, Y, 4 * SIZE + xvfmul.d VT0, VX0, VXC + xvfmadd.d VT0, VX2, VXS, VT0 + xvfmul.d VT1, VX0, VXS + xvfmsub.d VT1, VX2, VXC, VT1 + xvst VT0, X, 0 * SIZE + xvst VT1, Y, 0 * SIZE + xvfmul.d VT0, VX1, VXC + xvfmadd.d VT0, VX3, VXS, VT0 + xvfmul.d VT1, VX1, VXS + xvfmsub.d VT1, VX3, VXC, VT1 + xvst VT0, X, 4 * SIZE + xvst VT1, Y, 4 * SIZE + addi.d X, X, 8 * SIZE + addi.d Y, Y, 8 * SIZE + addi.d I, I, -1 + blt $r0, I, .L111 + b .L997 + .align 3 + +.L112: // C!=0 S==0 + xvld VX0, X, 0 * SIZE + xvld VX2, Y, 0 * SIZE + xvld VX1, X, 4 * SIZE + xvld VX3, Y, 4 * SIZE + xvfmul.d VT0, VX0, VXC + xvfmul.d VT1, VX2, VXC + xvst VT0, X, 0 * SIZE + xvst VT1, Y, 0 * SIZE + xvfmul.d VT0, VX1, VXC + xvfmul.d VT1, VX3, VXC + xvst VT0, X, 4 * SIZE + xvst VT1, Y, 4 * SIZE + addi.d X, X, 8 * SIZE + addi.d Y, Y, 8 * SIZE + addi.d I, I, -1 + blt $r0, I, .L112 + b .L997 + .align 3 + +.L113: // C==0 S!=0 + xvld VX0, X, 0 * SIZE + xvld VX2, Y, 0 * SIZE + xvld VX1, X, 4 * SIZE + xvld VX3, Y, 4 * SIZE + xvfmul.d VT0, VX2, VXS + xvfmul.d VT1, VX0, VXS + xvfsub.d VT1, VXZ, VT1 + xvst VT0, X, 0 * SIZE + xvst VT1, Y, 0 * SIZE + xvfmul.d VT0, VX3, VXS + xvfmul.d VT1, VX1, VXS + xvfsub.d VT1, VXZ, VT1 + xvst VT0, X, 4 * SIZE + xvst VT1, Y, 4 * SIZE + addi.d X, X, 8 * SIZE + addi.d Y, Y, 8 * SIZE + addi.d I, I, -1 + blt $r0, I, .L113 + b .L997 + .align 3 + +.L114: // C==0 S==0 + xvst VXZ, X, 0 * SIZE + xvst VXZ, Y, 0 * SIZE + xvst VXZ, X, 4 * SIZE + xvst VXZ, Y, 4 * SIZE + addi.d X, X, 8 * SIZE + addi.d Y, Y, 8 * SIZE + addi.d I, I, -1 + blt $r0, I, .L114 + b .L997 + .align 3 + +.L12: // INCX==1 and INCY!=1 + bge $r0, I, .L997 + move YY, Y + move XX, X + fcmp.ceq.d $fcc0, C, a1 + bcnez $fcc0, .L120 + fcmp.ceq.d $fcc0, S, a1 + bcnez $fcc0, .L122 // C!=0 S==0 + b .L121 // C!=0 S!=0 + .align 3 + +.L120: + fcmp.ceq.d $fcc0, S, a1 + bcnez $fcc0, .L124 // C==0 S==0 + b .L123 // C==0 S!=0 + .align 3 + +.L121: // C!=0 S!=0 + xvld VX0, X, 0 * SIZE + ld.d t1, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t2, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t3, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t4, Y, 0 * SIZE + xvinsgr2vr.d VX2, t1, 0 + xvinsgr2vr.d VX2, t2, 1 + xvinsgr2vr.d VX2, t3, 2 + xvinsgr2vr.d VX2, t4, 3 + add.d Y, Y, INCY + xvfmul.d VT0, VX0, VXC + xvfmadd.d VT0, VX2, VXS, VT0 + xvfmul.d VT1, VX0, VXS + xvfmsub.d VT1, VX2, VXC, VT1 + xvld VX1, X, 4 * SIZE + xvst VT0, X, 0 * SIZE + xvstelm.d VT1, YY, 0, 0 + add.d YY, YY, INCY + xvstelm.d VT1, YY, 0, 1 + add.d YY, YY, INCY + xvstelm.d VT1, YY, 0, 2 + add.d YY, YY, INCY + xvstelm.d VT1, YY, 0, 3 + add.d YY, YY, INCY + ld.d t1, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t2, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t3, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t4, Y, 0 * SIZE + xvinsgr2vr.d VX3, t1, 0 + xvinsgr2vr.d VX3, t2, 1 + xvinsgr2vr.d VX3, t3, 2 + xvinsgr2vr.d VX3, t4, 3 + add.d Y, Y, INCY + xvfmul.d VT0, VX1, VXC + xvfmadd.d VT0, VX3, VXS, VT0 + xvfmul.d VT1, VX1, VXS + xvfmsub.d VT1, VX3, VXC, VT1 + addi.d I, I, -1 + xvst VT0, X, 4 * SIZE + xvstelm.d VT1, YY, 0, 0 + add.d YY, YY, INCY + xvstelm.d VT1, YY, 0, 1 + add.d YY, YY, INCY + xvstelm.d VT1, YY, 0, 2 + add.d YY, YY, INCY + xvstelm.d VT1, YY, 0, 3 + add.d YY, YY, INCY + addi.d X, X, 8 * SIZE + blt $r0, I, .L121 + b .L997 + .align 3 + +.L122: // C!=0 S==0 + xvld VX0, X, 0 * SIZE + ld.d t1, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t2, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t3, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t4, Y, 0 * SIZE + xvinsgr2vr.d VX2, t1, 0 + xvinsgr2vr.d VX2, t2, 1 + xvinsgr2vr.d VX2, t3, 2 + xvinsgr2vr.d VX2, t4, 3 + add.d Y, Y, INCY + xvfmul.d VT0, VX0, VXC + xvfmul.d VT1, VX2, VXC + xvld VX1, X, 4 * SIZE + xvst VT0, X, 0 * SIZE + xvstelm.d VT1, YY, 0, 0 + add.d YY, YY, INCY + xvstelm.d VT1, YY, 0, 1 + add.d YY, YY, INCY + xvstelm.d VT1, YY, 0, 2 + add.d YY, YY, INCY + xvstelm.d VT1, YY, 0, 3 + add.d YY, YY, INCY + ld.d t1, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t2, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t3, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t4, Y, 0 * SIZE + xvinsgr2vr.d VX3, t1, 0 + xvinsgr2vr.d VX3, t2, 1 + xvinsgr2vr.d VX3, t3, 2 + xvinsgr2vr.d VX3, t4, 3 + add.d Y, Y, INCY + xvfmul.d VT0, VX1, VXC + xvfmul.d VT1, VX3, VXC + addi.d I, I, -1 + xvst VT0, X, 4 * SIZE + xvstelm.d VT1, YY, 0, 0 + add.d YY, YY, INCY + xvstelm.d VT1, YY, 0, 1 + add.d YY, YY, INCY + xvstelm.d VT1, YY, 0, 2 + add.d YY, YY, INCY + xvstelm.d VT1, YY, 0, 3 + add.d YY, YY, INCY + addi.d X, X, 8 * SIZE + blt $r0, I, .L122 + b .L997 + .align 3 + +.L123: // C==0 S!=0 + xvld VX0, X, 0 * SIZE + ld.d t1, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t2, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t3, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t4, Y, 0 * SIZE + xvinsgr2vr.d VX2, t1, 0 + xvinsgr2vr.d VX2, t2, 1 + xvinsgr2vr.d VX2, t3, 2 + xvinsgr2vr.d VX2, t4, 3 + add.d Y, Y, INCY + xvfmul.d VT0, VX2, VXS + xvfmul.d VT1, VX0, VXS + xvfsub.d VT1, VXZ, VT1 + xvst VT0, X, 0 * SIZE + xvstelm.d VT1, YY, 0, 0 + add.d YY, YY, INCY + xvstelm.d VT1, YY, 0, 1 + add.d YY, YY, INCY + xvstelm.d VT1, YY, 0, 2 + add.d YY, YY, INCY + xvstelm.d VT1, YY, 0, 3 + add.d YY, YY, INCY + xvld VX1, X, 4 * SIZE + ld.d t1, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t2, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t3, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t4, Y, 0 * SIZE + xvinsgr2vr.d VX3, t1, 0 + xvinsgr2vr.d VX3, t2, 1 + xvinsgr2vr.d VX3, t3, 2 + xvinsgr2vr.d VX3, t4, 3 + add.d Y, Y, INCY + xvfmul.d VT0, VX3, VXS + xvfmul.d VT1, VX1, VXS + xvfsub.d VT1, VXZ, VT1 + addi.d I, I, -1 + xvst VT0, X, 4 * SIZE + xvstelm.d VT1, YY, 0, 0 + add.d YY, YY, INCY + xvstelm.d VT1, YY, 0, 1 + add.d YY, YY, INCY + xvstelm.d VT1, YY, 0, 2 + add.d YY, YY, INCY + xvstelm.d VT1, YY, 0, 3 + add.d YY, YY, INCY + addi.d X, X, 8 * SIZE + blt $r0, I, .L123 + b .L997 + .align 3 + +.L124: // C==0 S==0 + xvst VXZ, X, 0 * SIZE + xvst VXZ, X, 4 * SIZE + xvstelm.d VXZ, YY, 0, 0 + add.d YY, YY, INCY + xvstelm.d VXZ, YY, 0, 1 + add.d YY, YY, INCY + xvstelm.d VXZ, YY, 0, 2 + add.d YY, YY, INCY + xvstelm.d VXZ, YY, 0, 3 + add.d YY, YY, INCY + xvstelm.d VXZ, YY, 0, 0 + add.d YY, YY, INCY + xvstelm.d VXZ, YY, 0, 1 + add.d YY, YY, INCY + xvstelm.d VXZ, YY, 0, 2 + add.d YY, YY, INCY + xvstelm.d VXZ, YY, 0, 3 + add.d YY, YY, INCY + addi.d I, I, -1 + blt $r0, I, .L124 + b .L997 + .align 3 + +.L21:// INCX!=1 and INCY==1 + bge $r0, I, .L997 + move XX, X + fcmp.ceq.d $fcc0, C, a1 + bcnez $fcc0, .L210 + fcmp.ceq.d $fcc0, S, a1 + bcnez $fcc0, .L212 // C!=0 S==0 + b .L211 // C!=0 S!=0 + .align 3 + +.L210: + fcmp.ceq.d $fcc0, S, a1 + bcnez $fcc0, .L214 // C==0 S==0 + b .L213 // C==0 S!=0 + .align 3 + +.L211: // C!=0 S!=0 + xvld VX2, Y, 0 * SIZE + ld.d t1, X, 0 * SIZE + add.d X, X, INCX + ld.d t2, X, 0 * SIZE + add.d X, X, INCX + ld.d t3, X, 0 * SIZE + add.d X, X, INCX + ld.d t4, X, 0 * SIZE + xvinsgr2vr.d VX0, t1, 0 + xvinsgr2vr.d VX0, t2, 1 + xvinsgr2vr.d VX0, t3, 2 + xvinsgr2vr.d VX0, t4, 3 + add.d X, X, INCX + xvfmul.d VT0, VXC, VX0 + xvfmadd.d VT0, VX2, VXS, VT0 + xvfmul.d VT1, VXS, VX0 + xvfmsub.d VT1, VX2, VXC, VT1 + xvstelm.d VT0, XX, 0, 0 + add.d XX, XX, INCX + xvstelm.d VT0, XX, 0, 1 + add.d XX, XX, INCX + xvstelm.d VT0, XX, 0, 2 + add.d XX, XX, INCX + xvstelm.d VT0, XX, 0, 3 + add.d XX, XX, INCX + xvst VT1, Y, 0 * SIZE + xvld VX3, Y, 4 * SIZE + ld.d t1, X, 0 * SIZE + add.d X, X, INCX + ld.d t2, X, 0 * SIZE + add.d X, X, INCX + ld.d t3, X, 0 * SIZE + add.d X, X, INCX + ld.d t4, X, 0 * SIZE + xvinsgr2vr.d VX1, t1, 0 + xvinsgr2vr.d VX1, t2, 1 + xvinsgr2vr.d VX1, t3, 2 + xvinsgr2vr.d VX1, t4, 3 + add.d X, X, INCX + xvfmul.d VT0, VX1, VXC + xvfmadd.d VT0, VX3, VXS, VT0 + xvfmul.d VT1, VX1, VXS + xvfmsub.d VT1, VX3, VXC, VT1 + xvstelm.d VT0, XX, 0, 0 + add.d XX, XX, INCX + xvstelm.d VT0, XX, 0, 1 + add.d XX, XX, INCX + xvstelm.d VT0, XX, 0, 2 + add.d XX, XX, INCX + xvstelm.d VT0, XX, 0, 3 + add.d XX, XX, INCX + xvst VT1, Y, 4 * SIZE + addi.d Y, Y, 8 * SIZE + addi.d I, I, -1 + blt $r0, I, .L211 + b .L997 + .align 3 + +.L212: // C!=0 S==0 + xvld VX2, Y, 0 * SIZE + ld.d t1, X, 0 * SIZE + add.d X, X, INCX + ld.d t2, X, 0 * SIZE + add.d X, X, INCX + ld.d t3, X, 0 * SIZE + add.d X, X, INCX + ld.d t4, X, 0 * SIZE + xvinsgr2vr.d VX0, t1, 0 + xvinsgr2vr.d VX0, t2, 1 + xvinsgr2vr.d VX0, t3, 2 + xvinsgr2vr.d VX0, t4, 3 + add.d X, X, INCX + xvfmul.d VT0, VXC, VX0 + xvstelm.d VT0, XX, 0, 0 + add.d XX, XX, INCX + xvstelm.d VT0, XX, 0, 1 + add.d XX, XX, INCX + xvstelm.d VT0, XX, 0, 2 + add.d XX, XX, INCX + xvstelm.d VT0, XX, 0, 3 + add.d XX, XX, INCX + xvfmul.d VT1, VX2, VXC + xvst VT1, Y, 0 * SIZE + xvld VX3, Y, 4 * SIZE + ld.d t1, X, 0 * SIZE + add.d X, X, INCX + ld.d t2, X, 0 * SIZE + add.d X, X, INCX + ld.d t3, X, 0 * SIZE + add.d X, X, INCX + ld.d t4, X, 0 * SIZE + xvinsgr2vr.d VX1, t1, 0 + xvinsgr2vr.d VX1, t2, 1 + xvinsgr2vr.d VX1, t3, 2 + xvinsgr2vr.d VX1, t4, 3 + add.d X, X, INCX + xvfmul.d VT0, VX1, VXC + xvstelm.d VT0, XX, 0, 0 + add.d XX, XX, INCX + xvstelm.d VT0, XX, 0, 1 + add.d XX, XX, INCX + xvstelm.d VT0, XX, 0, 2 + add.d XX, XX, INCX + xvstelm.d VT0, XX, 0, 3 + add.d XX, XX, INCX + xvfmul.d VT1, VX3, VXS + xvst VT1, Y, 4 * SIZE + addi.d Y, Y, 8 * SIZE + addi.d I, I, -1 + blt $r0, I, .L212 + b .L997 + .align 3 + +.L213: // C==0 S!=0 + xvld VX2, Y, 0 * SIZE + ld.d t1, X, 0 * SIZE + add.d X, X, INCX + ld.d t2, X, 0 * SIZE + add.d X, X, INCX + ld.d t3, X, 0 * SIZE + add.d X, X, INCX + ld.d t4, X, 0 * SIZE + xvinsgr2vr.d VX0, t1, 0 + xvinsgr2vr.d VX0, t2, 1 + xvinsgr2vr.d VX0, t3, 2 + xvinsgr2vr.d VX0, t4, 3 + add.d X, X, INCX + xvfmul.d VT0, VXS, VX2 + xvfmul.d VT1, VXS, VX0 + xvfsub.d VT1, VXZ, VT1 + xvstelm.d VT0, XX, 0, 0 + add.d XX, XX, INCX + xvstelm.d VT0, XX, 0, 1 + add.d XX, XX, INCX + xvstelm.d VT0, XX, 0, 2 + add.d XX, XX, INCX + xvstelm.d VT0, XX, 0, 3 + add.d XX, XX, INCX + xvst VT1, Y, 0 * SIZE + xvld VX3, Y, 4 * SIZE + ld.d t1, X, 0 * SIZE + add.d X, X, INCX + ld.d t2, X, 0 * SIZE + add.d X, X, INCX + ld.d t3, X, 0 * SIZE + add.d X, X, INCX + ld.d t4, X, 0 * SIZE + xvinsgr2vr.d VX1, t1, 0 + xvinsgr2vr.d VX1, t2, 1 + xvinsgr2vr.d VX1, t3, 2 + xvinsgr2vr.d VX1, t4, 3 + add.d X, X, INCX + xvfmul.d VT0, VX3, VXS + xvfmul.d VT1, VX1, VXS + xvfsub.d VT1, VXZ, VT1 + xvstelm.d VT0, XX, 0, 0 + add.d XX, XX, INCX + xvstelm.d VT0, XX, 0, 1 + add.d XX, XX, INCX + xvstelm.d VT0, XX, 0, 2 + add.d XX, XX, INCX + xvstelm.d VT0, XX, 0, 3 + add.d XX, XX, INCX + xvst VT1, Y, 4 * SIZE + addi.d Y, Y, 8 * SIZE + addi.d I, I, -1 + blt $r0, I, .L213 + b .L997 + .align 3 + +.L214: // C==0 S==0 + xvstelm.d VXZ, XX, 0, 0 + add.d XX, XX, INCX + xvstelm.d VXZ, XX, 0, 1 + add.d XX, XX, INCX + xvstelm.d VXZ, XX, 0, 2 + add.d XX, XX, INCX + xvstelm.d VXZ, XX, 0, 3 + add.d XX, XX, INCX + xvst VT1, Y, 0 * SIZE + xvstelm.d VXZ, XX, 0, 0 + add.d XX, XX, INCX + xvstelm.d VXZ, XX, 0, 1 + add.d XX, XX, INCX + xvstelm.d VXZ, XX, 0, 2 + add.d XX, XX, INCX + xvstelm.d VXZ, XX, 0, 3 + add.d XX, XX, INCX + xvst VT1, Y, 4 * SIZE + addi.d Y, Y, 8 * SIZE + addi.d I, I, -1 + blt $r0, I, .L211 + b .L997 + .align 3 + +.L22: + bge $r0, I, .L997 + move YY, Y + move XX, X + fcmp.ceq.d $fcc0, C, a1 + bcnez $fcc0, .L220 + fcmp.ceq.d $fcc0, S, a1 + bcnez $fcc0, .L222 // C!=0 S==0 + b .L221 // C!=0 S!=0 + .align 3 + +.L220: + fcmp.ceq.d $fcc0, S, a1 + bcnez $fcc0, .L224 // C==0 S==0 + b .L223 // C==0 S!=0 + .align 3 + +.L221: // C!=0 S!=0 + ld.d t1, X, 0 * SIZE + add.d X, X, INCX + ld.d t2, X, 0 * SIZE + add.d X, X, INCX + ld.d t3, X, 0 * SIZE + add.d X, X, INCX + ld.d t4, X, 0 * SIZE + add.d X, X, INCX + xvinsgr2vr.d VX0, t1, 0 + xvinsgr2vr.d VX0, t2, 1 + xvinsgr2vr.d VX0, t3, 2 + xvinsgr2vr.d VX0, t4, 3 + ld.d t1, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t2, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t3, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t4, Y, 0 * SIZE + xvinsgr2vr.d VX2, t1, 0 + xvinsgr2vr.d VX2, t2, 1 + xvinsgr2vr.d VX2, t3, 2 + xvinsgr2vr.d VX2, t4, 3 + add.d Y, Y, INCY + xvfmul.d VT0, VX0, VXC + xvfmadd.d VT0, VX2, VXS, VT0 + xvfmul.d VT1, VX0, VXS + xvfmsub.d VT1, VX2, VXC, VT1 + xvstelm.d VT0, XX, 0, 0 + add.d XX, XX, INCX + xvstelm.d VT0, XX, 0, 1 + add.d XX, XX, INCX + xvstelm.d VT0, XX, 0, 2 + add.d XX, XX, INCX + xvstelm.d VT0, XX, 0, 3 + add.d XX, XX, INCX + xvstelm.d VT1, YY, 0, 0 + add.d YY, YY, INCY + xvstelm.d VT1, YY, 0, 1 + add.d YY, YY, INCY + xvstelm.d VT1, YY, 0, 2 + add.d YY, YY, INCY + xvstelm.d VT1, YY, 0, 3 + add.d YY, YY, INCY + ld.d t1, X, 0 * SIZE + add.d X, X, INCX + ld.d t2, X, 0 * SIZE + add.d X, X, INCX + ld.d t3, X, 0 * SIZE + add.d X, X, INCX + ld.d t4, X, 0 * SIZE + add.d X, X, INCX + xvinsgr2vr.d VX1, t1, 0 + xvinsgr2vr.d VX1, t2, 1 + xvinsgr2vr.d VX1, t3, 2 + xvinsgr2vr.d VX1, t4, 3 + ld.d t1, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t2, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t3, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t4, Y, 0 * SIZE + xvinsgr2vr.d VX3, t1, 0 + xvinsgr2vr.d VX3, t2, 1 + xvinsgr2vr.d VX3, t3, 2 + xvinsgr2vr.d VX3, t4, 3 + add.d Y, Y, INCY + xvfmul.d VT0, VX1, VXC + xvfmadd.d VT0, VX3, VXS, VT0 + xvfmul.d VT1, VX0, VXS + xvfmsub.d VT1, VX3, VXC, VT1 + xvstelm.d VT0, XX, 0, 0 + add.d XX, XX, INCX + xvstelm.d VT0, XX, 0, 1 + add.d XX, XX, INCX + xvstelm.d VT0, XX, 0, 2 + add.d XX, XX, INCX + xvstelm.d VT0, XX, 0, 3 + add.d XX, XX, INCX + xvstelm.d VT1, YY, 0, 0 + add.d YY, YY, INCY + xvstelm.d VT1, YY, 0, 1 + add.d YY, YY, INCY + xvstelm.d VT1, YY, 0, 2 + add.d YY, YY, INCY + xvstelm.d VT1, YY, 0, 3 + add.d YY, YY, INCY + addi.d I, I, -1 + blt $r0, I, .L221 + b .L997 + .align 3 + +.L222: // C!=0 S==0 + ld.d t1, X, 0 * SIZE + add.d X, X, INCX + ld.d t2, X, 0 * SIZE + add.d X, X, INCX + ld.d t3, X, 0 * SIZE + add.d X, X, INCX + ld.d t4, X, 0 * SIZE + add.d X, X, INCX + xvinsgr2vr.d VX0, t1, 0 + xvinsgr2vr.d VX0, t2, 1 + xvinsgr2vr.d VX0, t3, 2 + xvinsgr2vr.d VX0, t4, 3 + ld.d t1, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t2, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t3, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t4, Y, 0 * SIZE + xvinsgr2vr.d VX2, t1, 0 + xvinsgr2vr.d VX2, t2, 1 + xvinsgr2vr.d VX2, t3, 2 + xvinsgr2vr.d VX2, t4, 3 + add.d Y, Y, INCY + xvfmul.d VT0, VX0, VXC + xvfmul.d VT1, VX2, VXC + xvstelm.d VT0, XX, 0, 0 + add.d XX, XX, INCX + xvstelm.d VT0, XX, 0, 1 + add.d XX, XX, INCX + xvstelm.d VT0, XX, 0, 2 + add.d XX, XX, INCX + xvstelm.d VT0, XX, 0, 3 + add.d XX, XX, INCX + xvstelm.d VT1, YY, 0, 0 + add.d YY, YY, INCY + xvstelm.d VT1, YY, 0, 1 + add.d YY, YY, INCY + xvstelm.d VT1, YY, 0, 2 + add.d YY, YY, INCY + xvstelm.d VT1, YY, 0, 3 + add.d YY, YY, INCY + ld.d t1, X, 0 * SIZE + add.d X, X, INCX + ld.d t2, X, 0 * SIZE + add.d X, X, INCX + ld.d t3, X, 0 * SIZE + add.d X, X, INCX + ld.d t4, X, 0 * SIZE + add.d X, X, INCX + xvinsgr2vr.d VX1, t1, 0 + xvinsgr2vr.d VX1, t2, 1 + xvinsgr2vr.d VX1, t3, 2 + xvinsgr2vr.d VX1, t4, 3 + ld.d t1, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t2, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t3, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t4, Y, 0 * SIZE + xvinsgr2vr.d VX3, t1, 0 + xvinsgr2vr.d VX3, t2, 1 + xvinsgr2vr.d VX3, t3, 2 + xvinsgr2vr.d VX3, t4, 3 + add.d Y, Y, INCY + xvfmul.d VT0, VX1, VXC + xvfmul.d VT1, VX3, VXC + xvstelm.d VT0, XX, 0, 0 + add.d XX, XX, INCX + xvstelm.d VT0, XX, 0, 1 + add.d XX, XX, INCX + xvstelm.d VT0, XX, 0, 2 + add.d XX, XX, INCX + xvstelm.d VT0, XX, 0, 3 + add.d XX, XX, INCX + xvstelm.d VT1, YY, 0, 0 + add.d YY, YY, INCY + xvstelm.d VT1, YY, 0, 1 + add.d YY, YY, INCY + xvstelm.d VT1, YY, 0, 2 + add.d YY, YY, INCY + xvstelm.d VT1, YY, 0, 3 + add.d YY, YY, INCY + addi.d I, I, -1 + blt $r0, I, .L222 + b .L997 + .align 3 + +.L223: // C==0 S!=0 + ld.d t1, X, 0 * SIZE + add.d X, X, INCX + ld.d t2, X, 0 * SIZE + add.d X, X, INCX + ld.d t3, X, 0 * SIZE + add.d X, X, INCX + ld.d t4, X, 0 * SIZE + add.d X, X, INCX + xvinsgr2vr.d VX0, t1, 0 + xvinsgr2vr.d VX0, t2, 1 + xvinsgr2vr.d VX0, t3, 2 + xvinsgr2vr.d VX0, t4, 3 + ld.d t1, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t2, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t3, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t4, Y, 0 * SIZE + xvinsgr2vr.d VX2, t1, 0 + xvinsgr2vr.d VX2, t2, 1 + xvinsgr2vr.d VX2, t3, 2 + xvinsgr2vr.d VX2, t4, 3 + add.d Y, Y, INCY + xvfmul.d VT0, VX2, VXS + xvfmul.d VT1, VX0, VXS + xvfsub.d VT1, VXZ, VT1 + xvstelm.d VT0, XX, 0, 0 + add.d XX, XX, INCX + xvstelm.d VT0, XX, 0, 1 + add.d XX, XX, INCX + xvstelm.d VT0, XX, 0, 2 + add.d XX, XX, INCX + xvstelm.d VT0, XX, 0, 3 + add.d XX, XX, INCX + xvstelm.d VT1, YY, 0, 0 + add.d YY, YY, INCY + xvstelm.d VT1, YY, 0, 1 + add.d YY, YY, INCY + xvstelm.d VT1, YY, 0, 2 + add.d YY, YY, INCY + xvstelm.d VT1, YY, 0, 3 + add.d YY, YY, INCY + ld.d t1, X, 0 * SIZE + add.d X, X, INCX + ld.d t2, X, 0 * SIZE + add.d X, X, INCX + ld.d t3, X, 0 * SIZE + add.d X, X, INCX + ld.d t4, X, 0 * SIZE + add.d X, X, INCX + xvinsgr2vr.d VX1, t1, 0 + xvinsgr2vr.d VX1, t2, 1 + xvinsgr2vr.d VX1, t3, 2 + xvinsgr2vr.d VX1, t4, 3 + ld.d t1, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t2, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t3, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t4, Y, 0 * SIZE + xvinsgr2vr.d VX3, t1, 0 + xvinsgr2vr.d VX3, t2, 1 + xvinsgr2vr.d VX3, t3, 2 + xvinsgr2vr.d VX3, t4, 3 + add.d Y, Y, INCY + xvfmul.d VT0, VX3, VXS + xvfmul.d VT1, VX0, VXS + xvfsub.d VT1, VXZ, VT1 + xvstelm.d VT0, XX, 0, 0 + add.d XX, XX, INCX + xvstelm.d VT0, XX, 0, 1 + add.d XX, XX, INCX + xvstelm.d VT0, XX, 0, 2 + add.d XX, XX, INCX + xvstelm.d VT0, XX, 0, 3 + add.d XX, XX, INCX + xvstelm.d VT1, YY, 0, 0 + add.d YY, YY, INCY + xvstelm.d VT1, YY, 0, 1 + add.d YY, YY, INCY + xvstelm.d VT1, YY, 0, 2 + add.d YY, YY, INCY + xvstelm.d VT1, YY, 0, 3 + add.d YY, YY, INCY + addi.d I, I, -1 + blt $r0, I, .L223 + b .L997 + .align 3 + +.L224: // C==0 S==0 + xvstelm.d VXZ, XX, 0, 0 + add.d XX, XX, INCX + xvstelm.d VXZ, XX, 0, 1 + add.d XX, XX, INCX + xvstelm.d VXZ, XX, 0, 2 + add.d XX, XX, INCX + xvstelm.d VXZ, XX, 0, 3 + add.d XX, XX, INCX + xvstelm.d VXZ, YY, 0, 0 + add.d YY, YY, INCY + xvstelm.d VXZ, YY, 0, 1 + add.d YY, YY, INCY + xvstelm.d VXZ, YY, 0, 2 + add.d YY, YY, INCY + xvstelm.d VXZ, YY, 0, 3 + add.d YY, YY, INCY + xvstelm.d VXZ, XX, 0, 0 + add.d XX, XX, INCX + xvstelm.d VXZ, XX, 0, 1 + add.d XX, XX, INCX + xvstelm.d VXZ, XX, 0, 2 + add.d XX, XX, INCX + xvstelm.d VXZ, XX, 0, 3 + add.d XX, XX, INCX + xvstelm.d VXZ, YY, 0, 0 + add.d YY, YY, INCY + xvstelm.d VXZ, YY, 0, 1 + add.d YY, YY, INCY + xvstelm.d VXZ, YY, 0, 2 + add.d YY, YY, INCY + xvstelm.d VXZ, YY, 0, 3 + add.d YY, YY, INCY + addi.d I, I, -1 + blt $r0, I, .L224 + b .L997 + .align 3 + +.L997: + andi I, N, 7 + bge $r0, I, .L999 + .align 3 + +.L998: + fld.d $f12, X, 0 * SIZE + fld.d $f13, Y, 0 * SIZE + fmul.d $f10, $f12, C + fmadd.d $f10, $f13, S, $f10 + fst.d $f10, X, 0 * SIZE + addi.d I, I, -1 + fmul.d $f20, $f12, S + fmsub.d $f20, $f13, C, $f20 + fst.d $f20, Y, 0 * SIZE + add.d X, X, INCX + add.d Y, Y, INCY + blt $r0, I, .L998 + .align 3 + +.L999: + move $r4, $r12 + jirl $r0, $r1, 0x0 + .align 3 + + EPILOGUE \ No newline at end of file diff --git a/kernel/loongarch64/drot_lsx.S b/kernel/loongarch64/drot_lsx.S new file mode 100644 index 000000000..6db803b1c --- /dev/null +++ b/kernel/loongarch64/drot_lsx.S @@ -0,0 +1,1050 @@ +#define ASSEMBLER + +#include "common.h" +#define N $r4 +#define X $r5 +#define INCX $r6 +#define Y $r7 +#define INCY $r8 +#define C $f0 +#define S $f1 + +#define I $r12 +#define TEMP $r13 +#define t1 $r14 +#define t2 $r16 +#define t3 $r15 +#define t4 $r17 +#define XX $r18 +#define YY $r19 +#define a1 $f12 +#define VX0 $vr8 +#define VX1 $vr20 +#define VX2 $vr21 +#define VX3 $vr22 +#define VT0 $vr10 +#define VT1 $vr18 +#define VXC $vr23 +#define VXS $vr9 +#define VXZ $vr19 + + PROLOGUE + + bge $r0, N, .L999 + li.d TEMP, 1 + movgr2fr.d a1, $r0 + ffint.d.l a1, a1 + slli.d TEMP, TEMP, BASE_SHIFT + slli.d INCX, INCX, BASE_SHIFT + slli.d INCY, INCY, BASE_SHIFT + movfr2gr.d t1, C + vreplgr2vr.d VXC, t1 + movfr2gr.d t2, S + vreplgr2vr.d VXS, t2 + movfr2gr.d t3, a1 + vreplgr2vr.d VXZ, t3 + srai.d I, N, 3 + bne INCX, TEMP, .L20 + bne INCY, TEMP, .L12 // INCX==1 and INCY!=1 + b .L11 // INCX==1 and INCY==1 +.L20: + bne INCY, TEMP, .L22 // INCX!=1 and INCY!=1 + b .L21 // INCX!=1 and INCY==1 + +.L11: + bge $r0, I, .L997 + fcmp.ceq.d $fcc0, C, a1 + bcnez $fcc0, .L110 + fcmp.ceq.d $fcc0, S, a1 + bcnez $fcc0, .L112 // C!=0 S==0 + b .L111 // C!=0 S!=0 + .align 3 + +.L110: + fcmp.ceq.d $fcc0, S, a1 + bcnez $fcc0, .L114 // C==0 S==0 + b .L113 // C==0 S!=0 + .align 3 + +.L111: // C!=0 S!=0 + vld VX0, X, 0 * SIZE + vld VX2, Y, 0 * SIZE + vld VX1, X, 2 * SIZE + vld VX3, Y, 2 * SIZE + vfmul.d VT0, VX0, VXC + vfmadd.d VT0, VX2, VXS, VT0 + vfmul.d VT1, VX0, VXS + vfmsub.d VT1, VX2, VXC, VT1 + vst VT0, X, 0 * SIZE + vst VT1, Y, 0 * SIZE + vfmul.d VT0, VX1, VXC + vfmadd.d VT0, VX3, VXS, VT0 + vfmul.d VT1, VX1, VXS + vfmsub.d VT1, VX3, VXC, VT1 + vst VT0, X, 2 * SIZE + vst VT1, Y, 2 * SIZE + vld VX0, X, 4 * SIZE + vld VX2, Y, 4 * SIZE + vld VX1, X, 6 * SIZE + vld VX3, Y, 6 * SIZE + vfmul.d VT0, VX0, VXC + vfmadd.d VT0, VX2, VXS, VT0 + vfmul.d VT1, VX0, VXS + vfmsub.d VT1, VX2, VXC, VT1 + vst VT0, X, 4 * SIZE + vst VT1, Y, 4 * SIZE + vfmul.d VT0, VX1, VXC + vfmadd.d VT0, VX3, VXS, VT0 + vfmul.d VT1, VX1, VXS + vfmsub.d VT1, VX3, VXC, VT1 + vst VT0, X, 6 * SIZE + vst VT1, Y, 6 * SIZE + addi.d X, X, 8 * SIZE + addi.d Y, Y, 8 * SIZE + addi.d I, I, -1 + blt $r0, I, .L111 + b .L997 + .align 3 + +.L112: // C!=0 S==0 + vld VX0, X, 0 * SIZE + vld VX2, Y, 0 * SIZE + vld VX1, X, 2 * SIZE + vld VX3, Y, 2 * SIZE + vfmul.d VT0, VX0, VXC + vfmul.d VT1, VX2, VXC + vst VT0, X, 0 * SIZE + vst VT1, Y, 0 * SIZE + vfmul.d VT0, VX1, VXC + vfmul.d VT1, VX3, VXC + vst VT0, X, 2 * SIZE + vst VT1, Y, 2 * SIZE + vld VX0, X, 4 * SIZE + vld VX2, Y, 4 * SIZE + vld VX1, X, 6 * SIZE + vld VX3, Y, 6 * SIZE + vfmul.d VT0, VX0, VXC + vfmul.d VT1, VX2, VXC + vst VT0, X, 4 * SIZE + vst VT1, Y, 4 * SIZE + vfmul.d VT0, VX1, VXC + vfmul.d VT1, VX3, VXC + vst VT0, X, 6 * SIZE + vst VT1, Y, 6 * SIZE + addi.d X, X, 8 * SIZE + addi.d Y, Y, 8 * SIZE + addi.d I, I, -1 + blt $r0, I, .L112 + b .L997 + .align 3 + +.L113: // C==0 S!=0 + vld VX0, X, 0 * SIZE + vld VX2, Y, 0 * SIZE + vld VX1, X, 2 * SIZE + vld VX3, Y, 2 * SIZE + vfmul.d VT0, VX2, VXS + vfmul.d VT1, VX0, VXS + vfsub.d VT1, VXZ, VT1 + vst VT0, X, 0 * SIZE + vst VT1, Y, 0 * SIZE + vfmul.d VT0, VX3, VXS + vfmul.d VT1, VX1, VXS + vfsub.d VT1, VXZ, VT1 + vst VT0, X, 2 * SIZE + vst VT1, Y, 2 * SIZE + vld VX0, X, 4 * SIZE + vld VX2, Y, 4 * SIZE + vld VX1, X, 6 * SIZE + vld VX3, Y, 6 * SIZE + vfmul.d VT0, VX2, VXS + vfmul.d VT1, VX0, VXS + vfsub.d VT1, VXZ, VT1 + vst VT0, X, 4 * SIZE + vst VT1, Y, 4 * SIZE + vfmul.d VT0, VX3, VXS + vfmul.d VT1, VX1, VXS + vfsub.d VT1, VXZ, VT1 + vst VT0, X, 6 * SIZE + vst VT1, Y, 6 * SIZE + addi.d X, X, 8 * SIZE + addi.d Y, Y, 8 * SIZE + addi.d I, I, -1 + blt $r0, I, .L113 + b .L997 + .align 3 + +.L114: // C==0 S==0 + vst VXZ, X, 0 * SIZE + vst VXZ, Y, 0 * SIZE + vst VXZ, X, 2 * SIZE + vst VXZ, Y, 2 * SIZE + vst VXZ, X, 4 * SIZE + vst VXZ, Y, 4 * SIZE + vst VXZ, X, 6 * SIZE + vst VXZ, Y, 6 * SIZE + addi.d X, X, 8 * SIZE + addi.d Y, Y, 8 * SIZE + addi.d I, I, -1 + blt $r0, I, .L114 + b .L997 + .align 3 + +.L12: // INCX==1 and INCY!=1 + bge $r0, I, .L997 + move YY, Y + move XX, X + fcmp.ceq.d $fcc0, C, a1 + bcnez $fcc0, .L120 + fcmp.ceq.d $fcc0, S, a1 + bcnez $fcc0, .L122 // C!=0 S==0 + b .L121 // C!=0 S!=0 + .align 3 + +.L120: + fcmp.ceq.d $fcc0, S, a1 + bcnez $fcc0, .L124 // C==0 S==0 + b .L123 // C==0 S!=0 + .align 3 + +.L121: // C!=0 S!=0 + vld VX0, X, 0 * SIZE + ld.d t1, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t2, Y, 0 * SIZE + vinsgr2vr.d VX2, t1, 0 + vinsgr2vr.d VX2, t2, 1 + add.d Y, Y, INCY + vfmul.d VT0, VX0, VXC + vfmadd.d VT0, VX2, VXS, VT0 + vfmul.d VT1, VX0, VXS + vfmsub.d VT1, VX2, VXC, VT1 + vst VT0, X, 0 * SIZE + vstelm.d VT1, YY, 0, 0 + add.d YY, YY, INCY + vstelm.d VT1, YY, 0, 1 + add.d YY, YY, INCY + vld VX0, X, 2 * SIZE + ld.d t3, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t4, Y, 0 * SIZE + vinsgr2vr.d VX2, t3, 0 + vinsgr2vr.d VX2, t4, 1 + add.d Y, Y, INCY + vfmul.d VT0, VX0, VXC + vfmadd.d VT0, VX2, VXS, VT0 + vfmul.d VT1, VX0, VXS + vfmsub.d VT1, VX2, VXC, VT1 + vst VT0, X, 2 * SIZE + vstelm.d VT1, YY, 0, 0 + add.d YY, YY, INCY + vstelm.d VT1, YY, 0, 1 + add.d YY, YY, INCY + vld VX1, X, 4 * SIZE + ld.d t1, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t2, Y, 0 * SIZE + vinsgr2vr.d VX3, t1, 0 + vinsgr2vr.d VX3, t2, 1 + add.d Y, Y, INCY + vfmul.d VT0, VX1, VXC + vfmadd.d VT0, VX3, VXS, VT0 + vfmul.d VT1, VX1, VXS + vfmsub.d VT1, VX3, VXC, VT1 + vst VT0, X, 4 * SIZE + vstelm.d VT1, YY, 0, 0 + add.d YY, YY, INCY + vstelm.d VT1, YY, 0, 1 + add.d YY, YY, INCY + vld VX1, X, 6 * SIZE + ld.d t3, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t4, Y, 0 * SIZE + vinsgr2vr.d VX3, t3, 0 + vinsgr2vr.d VX3, t4, 1 + add.d Y, Y, INCY + vfmul.d VT0, VX1, VXC + vfmadd.d VT0, VX3, VXS, VT0 + vfmul.d VT1, VX1, VXS + vfmsub.d VT1, VX3, VXC, VT1 + vst VT0, X, 6 * SIZE + vstelm.d VT1, YY, 0, 0 + add.d YY, YY, INCY + vstelm.d VT1, YY, 0, 1 + add.d YY, YY, INCY + addi.d X, X, 8 * SIZE + addi.d I, I, -1 + blt $r0, I, .L121 + b .L997 + .align 3 + +.L122: // C!=0 S==0 + vld VX0, X, 0 * SIZE + ld.d t1, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t2, Y, 0 * SIZE + vinsgr2vr.d VX2, t1, 0 + vinsgr2vr.d VX2, t2, 1 + add.d Y, Y, INCY + vfmul.d VT0, VX0, VXC + vfmul.d VT1, VX2, VXC + vst VT0, X, 0 * SIZE + vstelm.d VT1, YY, 0, 0 + add.d YY, YY, INCY + vstelm.d VT1, YY, 0, 1 + add.d YY, YY, INCY + vld VX0, X, 2 * SIZE + ld.d t3, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t4, Y, 0 * SIZE + vinsgr2vr.d VX2, t3, 0 + vinsgr2vr.d VX2, t4, 1 + add.d Y, Y, INCY + vfmul.d VT0, VX0, VXC + vfmul.d VT1, VX2, VXC + vst VT0, X, 2 * SIZE + vstelm.d VT1, YY, 0, 0 + add.d YY, YY, INCY + vstelm.d VT1, YY, 0, 1 + add.d YY, YY, INCY + vld VX1, X, 4 * SIZE + ld.d t1, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t2, Y, 0 * SIZE + vinsgr2vr.d VX3, t1, 0 + vinsgr2vr.d VX3, t2, 1 + add.d Y, Y, INCY + vfmul.d VT0, VX1, VXC + vfmul.d VT1, VX3, VXC + vst VT0, X, 4 * SIZE + vstelm.d VT1, YY, 0, 0 + add.d YY, YY, INCY + vstelm.d VT1, YY, 0, 1 + add.d YY, YY, INCY + vld VX1, X, 6 * SIZE + ld.d t3, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t4, Y, 0 * SIZE + vinsgr2vr.d VX3, t3, 0 + vinsgr2vr.d VX3, t4, 1 + add.d Y, Y, INCY + vfmul.d VT0, VX1, VXC + vfmul.d VT1, VX3, VXC + vst VT0, X, 6 * SIZE + vstelm.d VT1, YY, 0, 0 + add.d YY, YY, INCY + vstelm.d VT1, YY, 0, 1 + add.d YY, YY, INCY + addi.d X, X, 8 * SIZE + addi.d I, I, -1 + blt $r0, I, .L122 + b .L997 + .align 3 + +.L123: // C==0 S!=0 + vld VX0, X, 0 * SIZE + ld.d t1, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t2, Y, 0 * SIZE + vinsgr2vr.d VX2, t1, 0 + vinsgr2vr.d VX2, t2, 1 + add.d Y, Y, INCY + vfmul.d VT0, VX2, VXS + vfmul.d VT1, VX0, VXS + vfsub.d VT1, VXZ, VT1 + vst VT0, X, 0 * SIZE + vstelm.d VT1, YY, 0, 0 + add.d YY, YY, INCY + vstelm.d VT1, YY, 0, 1 + add.d YY, YY, INCY + vld VX0, X, 2 * SIZE + ld.d t3, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t4, Y, 0 * SIZE + vinsgr2vr.d VX2, t3, 0 + vinsgr2vr.d VX2, t4, 1 + add.d Y, Y, INCY + vfmul.d VT0, VX2, VXS + vfmul.d VT1, VX0, VXS + vfsub.d VT1, VXZ, VT1 + vst VT0, X, 2 * SIZE + vstelm.d VT1, YY, 0, 0 + add.d YY, YY, INCY + vstelm.d VT1, YY, 0, 1 + add.d YY, YY, INCY + vld VX1, X, 4 * SIZE + ld.d t1, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t2, Y, 0 * SIZE + vinsgr2vr.d VX3, t1, 0 + vinsgr2vr.d VX3, t2, 1 + add.d Y, Y, INCY + vfmul.d VT0, VX3, VXS + vfmul.d VT1, VX1, VXS + vfsub.d VT1, VXZ, VT1 + vst VT0, X, 4 * SIZE + vstelm.d VT1, YY, 0, 0 + add.d YY, YY, INCY + vstelm.d VT1, YY, 0, 1 + add.d YY, YY, INCY + vld VX1, X, 6 * SIZE + ld.d t3, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t4, Y, 0 * SIZE + vinsgr2vr.d VX3, t3, 0 + vinsgr2vr.d VX3, t4, 1 + add.d Y, Y, INCY + vfmul.d VT0, VX3, VXS + vfmul.d VT1, VX1, VXS + vfsub.d VT1, VXZ, VT1 + vst VT0, X, 6 * SIZE + vstelm.d VT1, YY, 0, 0 + add.d YY, YY, INCY + vstelm.d VT1, YY, 0, 1 + add.d YY, YY, INCY + addi.d X, X, 8 * SIZE + addi.d I, I, -1 + blt $r0, I, .L123 + b .L997 + .align 3 + +.L124: // C==0 S==0 + vst VXZ, X, 0 * SIZE + vst VXZ, X, 4 * SIZE + vstelm.d VXZ, YY, 0, 0 + add.d YY, YY, INCY + vstelm.d VXZ, YY, 0, 1 + add.d YY, YY, INCY + vstelm.d VXZ, YY, 0, 0 + add.d YY, YY, INCY + vstelm.d VXZ, YY, 0, 1 + add.d YY, YY, INCY + vstelm.d VXZ, YY, 0, 0 + add.d YY, YY, INCY + vstelm.d VXZ, YY, 0, 1 + add.d YY, YY, INCY + vstelm.d VXZ, YY, 0, 0 + add.d YY, YY, INCY + vstelm.d VXZ, YY, 0, 1 + add.d YY, YY, INCY + addi.d I, I, -1 + blt $r0, I, .L124 + b .L997 + .align 3 + +.L21:// INCX!=1 and INCY==1 + bge $r0, I, .L997 + move XX, X + fcmp.ceq.d $fcc0, C, a1 + bcnez $fcc0, .L210 + fcmp.ceq.d $fcc0, S, a1 + bcnez $fcc0, .L212 // C!=0 S==0 + b .L211 // C!=0 S!=0 + .align 3 + +.L210: + fcmp.ceq.d $fcc0, S, a1 + bcnez $fcc0, .L214 // C==0 S==0 + b .L213 // C==0 S!=0 + .align 3 + +.L211: // C!=0 S!=0 + vld VX2, Y, 0 * SIZE + ld.d t1, X, 0 * SIZE + add.d X, X, INCX + ld.d t2, X, 0 * SIZE + vinsgr2vr.d VX0, t1, 0 + vinsgr2vr.d VX0, t2, 1 + add.d X, X, INCX + vfmul.d VT0, VXC, VX0 + vfmadd.d VT0, VX2, VXS, VT0 + vfmul.d VT1, VXS, VX0 + vfmsub.d VT1, VX2, VXC, VT1 + vstelm.d VT0, XX, 0, 0 + add.d XX, XX, INCX + vstelm.d VT0, XX, 0, 1 + add.d XX, XX, INCX + vst VT1, Y, 0 * SIZE + vld VX2, Y, 2 * SIZE + ld.d t3, X, 0 * SIZE + add.d X, X, INCX + ld.d t4, X, 0 * SIZE + vinsgr2vr.d VX0, t3, 0 + vinsgr2vr.d VX0, t4, 1 + add.d X, X, INCX + vfmul.d VT0, VXC, VX0 + vfmadd.d VT0, VX2, VXS, VT0 + vfmul.d VT1, VXS, VX0 + vfmsub.d VT1, VX2, VXC, VT1 + vstelm.d VT0, XX, 0, 0 + add.d XX, XX, INCX + vstelm.d VT0, XX, 0, 1 + add.d XX, XX, INCX + vst VT1, Y, 2 * SIZE + vld VX3, Y, 4 * SIZE + ld.d t1, X, 0 * SIZE + add.d X, X, INCX + ld.d t2, X, 0 * SIZE + vinsgr2vr.d VX1, t1, 0 + vinsgr2vr.d VX1, t2, 1 + add.d X, X, INCX + vfmul.d VT0, VX1, VXC + vfmadd.d VT0, VX3, VXS, VT0 + vfmul.d VT1, VX1, VXS + vfmsub.d VT1, VX3, VXC, VT1 + vstelm.d VT0, XX, 0, 0 + add.d XX, XX, INCX + vstelm.d VT0, XX, 0, 1 + add.d XX, XX, INCX + vst VT1, Y, 4 * SIZE + vld VX3, Y, 6 * SIZE + ld.d t3, X, 0 * SIZE + add.d X, X, INCX + ld.d t4, X, 0 * SIZE + vinsgr2vr.d VX1, t3, 0 + vinsgr2vr.d VX1, t4, 1 + add.d X, X, INCX + vfmul.d VT0, VX1, VXC + vfmadd.d VT0, VX3, VXS, VT0 + vfmul.d VT1, VX1, VXS + vfmsub.d VT1, VX3, VXC, VT1 + vstelm.d VT0, XX, 0, 0 + add.d XX, XX, INCX + vstelm.d VT0, XX, 0, 1 + add.d XX, XX, INCX + vst VT1, Y, 6 * SIZE + addi.d Y, Y, 8 * SIZE + addi.d I, I, -1 + blt $r0, I, .L211 + b .L997 + .align 3 + +.L212: // C!=0 S==0 + vld VX2, Y, 0 * SIZE + ld.d t1, X, 0 * SIZE + add.d X, X, INCX + ld.d t2, X, 0 * SIZE + vinsgr2vr.d VX0, t1, 0 + vinsgr2vr.d VX0, t2, 1 + add.d X, X, INCX + vfmul.d VT0, VXC, VX0 + vfmul.d VT1, VX2, VXC + vstelm.d VT0, XX, 0, 0 + add.d XX, XX, INCX + vstelm.d VT0, XX, 0, 1 + add.d XX, XX, INCX + vst VT1, Y, 0 * SIZE + vld VX2, Y, 2 * SIZE + ld.d t3, X, 0 * SIZE + add.d X, X, INCX + ld.d t4, X, 0 * SIZE + vinsgr2vr.d VX0, t3, 0 + vinsgr2vr.d VX0, t4, 1 + add.d X, X, INCX + vfmul.d VT0, VXC, VX0 + vfmul.d VT1, VX2, VXC + vstelm.d VT0, XX, 0, 0 + add.d XX, XX, INCX + vstelm.d VT0, XX, 0, 1 + add.d XX, XX, INCX + vst VT1, Y, 2 * SIZE + vld VX3, Y, 4 * SIZE + ld.d t1, X, 0 * SIZE + add.d X, X, INCX + ld.d t2, X, 0 * SIZE + vinsgr2vr.d VX1, t1, 0 + vinsgr2vr.d VX1, t2, 1 + add.d X, X, INCX + vfmul.d VT0, VX1, VXC + vfmul.d VT1, VX3, VXS + vstelm.d VT0, XX, 0, 0 + add.d XX, XX, INCX + vstelm.d VT0, XX, 0, 1 + add.d XX, XX, INCX + vst VT1, Y, 4 * SIZE + vld VX3, Y, 6 * SIZE + ld.d t3, X, 0 * SIZE + add.d X, X, INCX + ld.d t4, X, 0 * SIZE + vinsgr2vr.d VX1, t3, 0 + vinsgr2vr.d VX1, t4, 1 + add.d X, X, INCX + vfmul.d VT0, VX1, VXC + vfmul.d VT1, VX3, VXS + vstelm.d VT0, XX, 0, 0 + add.d XX, XX, INCX + vstelm.d VT0, XX, 0, 1 + vst VT1, Y, 6 * SIZE + addi.d Y, Y, 8 * SIZE + addi.d I, I, -1 + blt $r0, I, .L212 + b .L997 + .align 3 + +.L213: // C==0 S!=0 + vld VX2, Y, 0 * SIZE + ld.d t1, X, 0 * SIZE + add.d X, X, INCX + ld.d t2, X, 0 * SIZE + vinsgr2vr.d VX0, t1, 0 + vinsgr2vr.d VX0, t2, 1 + add.d X, X, INCX + vfmul.d VT0, VXS, VX2 + vfmul.d VT1, VXS, VX0 + vfsub.d VT1, VXZ, VT1 + vstelm.d VT0, XX, 0, 0 + add.d XX, XX, INCX + vstelm.d VT0, XX, 0, 1 + add.d XX, XX, INCX + vst VT1, Y, 0 * SIZE + vld VX2, Y, 2 * SIZE + ld.d t3, X, 0 * SIZE + add.d X, X, INCX + ld.d t4, X, 0 * SIZE + vinsgr2vr.d VX0, t3, 0 + vinsgr2vr.d VX0, t4, 1 + add.d X, X, INCX + vfmul.d VT0, VXS, VX2 + vfmul.d VT1, VXS, VX0 + vfsub.d VT1, VXZ, VT1 + vstelm.d VT0, XX, 0, 0 + add.d XX, XX, INCX + vstelm.d VT0, XX, 0, 1 + add.d XX, XX, INCX + vst VT1, Y, 2 * SIZE + vld VX3, Y, 4 * SIZE + ld.d t1, X, 0 * SIZE + add.d X, X, INCX + ld.d t2, X, 0 * SIZE + vinsgr2vr.d VX1, t1, 0 + vinsgr2vr.d VX1, t2, 1 + add.d X, X, INCX + vfmul.d VT0, VX3, VXS + vfmul.d VT1, VX1, VXS + vfsub.d VT1, VXZ, VT1 + vstelm.d VT0, XX, 0, 0 + add.d XX, XX, INCX + vstelm.d VT0, XX, 0, 1 + add.d XX, XX, INCX + vst VT1, Y, 4 * SIZE + vld VX3, Y, 6 * SIZE + ld.d t3, X, 0 * SIZE + add.d X, X, INCX + ld.d t4, X, 0 * SIZE + vinsgr2vr.d VX1, t3, 0 + vinsgr2vr.d VX1, t4, 1 + add.d X, X, INCX + vfmul.d VT0, VX3, VXS + vfmul.d VT1, VX1, VXS + vfsub.d VT1, VXZ, VT1 + vstelm.d VT0, XX, 0, 0 + add.d XX, XX, INCX + vstelm.d VT0, XX, 0, 1 + add.d XX, XX, INCX + vst VT1, Y, 6 * SIZE + addi.d Y, Y, 8 * SIZE + addi.d I, I, -1 + blt $r0, I, .L213 + b .L997 + .align 3 + +.L214: // C==0 S==0 + vstelm.d VXZ, XX, 0, 0 + add.d XX, XX, INCX + vstelm.d VXZ, XX, 0, 1 + add.d XX, XX, INCX + vstelm.d VXZ, XX, 0, 0 + add.d XX, XX, INCX + vstelm.d VXZ, XX, 0, 1 + add.d XX, XX, INCX + vst VT1, Y, 0 * SIZE + vstelm.d VXZ, XX, 0, 0 + add.d XX, XX, INCX + vstelm.d VXZ, XX, 0, 1 + add.d XX, XX, INCX + vstelm.d VXZ, XX, 0, 0 + add.d XX, XX, INCX + vstelm.d VXZ, XX, 0, 1 + add.d XX, XX, INCX + vst VT1, Y, 4 * SIZE + addi.d Y, Y, 8 * SIZE + addi.d I, I, -1 + blt $r0, I, .L211 + b .L997 + .align 3 + +.L22: + bge $r0, I, .L997 + move YY, Y + move XX, X + fcmp.ceq.d $fcc0, C, a1 + bcnez $fcc0, .L220 + fcmp.ceq.d $fcc0, S, a1 + bcnez $fcc0, .L222 // C!=0 S==0 + b .L221 // C!=0 S!=0 + .align 3 + +.L220: + fcmp.ceq.d $fcc0, S, a1 + bcnez $fcc0, .L224 // C==0 S==0 + b .L223 // C==0 S!=0 + .align 3 + +.L221: // C!=0 S!=0 + ld.d t1, X, 0 * SIZE + add.d X, X, INCX + ld.d t2, X, 0 * SIZE + vinsgr2vr.d VX0, t1, 0 + vinsgr2vr.d VX0, t2, 1 + add.d X, X, INCX + ld.d t1, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t2, Y, 0 * SIZE + vinsgr2vr.d VX2, t1, 0 + vinsgr2vr.d VX2, t2, 1 + add.d Y, Y, INCY + vfmul.d VT0, VX0, VXC + vfmadd.d VT0, VX2, VXS, VT0 + vfmul.d VT1, VX0, VXS + vfmsub.d VT1, VX2, VXC, VT1 + vstelm.d VT0, XX, 0, 0 + add.d XX, XX, INCX + vstelm.d VT0, XX, 0, 1 + add.d XX, XX, INCX + vstelm.d VT1, YY, 0, 0 + add.d YY, YY, INCY + vstelm.d VT1, YY, 0, 1 + add.d YY, YY, INCY + ld.d t3, X, 0 * SIZE + add.d X, X, INCX + ld.d t4, X, 0 * SIZE + add.d X, X, INCX + vinsgr2vr.d VX0, t3, 0 + vinsgr2vr.d VX0, t4, 1 + ld.d t3, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t4, Y, 0 * SIZE + vinsgr2vr.d VX2, t3, 0 + vinsgr2vr.d VX2, t4, 1 + add.d Y, Y, INCY + vfmul.d VT0, VX0, VXC + vfmadd.d VT0, VX2, VXS, VT0 + vfmul.d VT1, VX0, VXS + vfmsub.d VT1, VX2, VXC, VT1 + vstelm.d VT0, XX, 0, 0 + add.d XX, XX, INCX + vstelm.d VT0, XX, 0, 1 + add.d XX, XX, INCX + vstelm.d VT1, YY, 0, 0 + add.d YY, YY, INCY + vstelm.d VT1, YY, 0, 1 + add.d YY, YY, INCY + ld.d t1, X, 0 * SIZE + add.d X, X, INCX + ld.d t2, X, 0 * SIZE + add.d X, X, INCX + vinsgr2vr.d VX1, t1, 0 + vinsgr2vr.d VX1, t2, 1 + ld.d t1, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t2, Y, 0 * SIZE + vinsgr2vr.d VX3, t1, 0 + vinsgr2vr.d VX3, t2, 1 + add.d Y, Y, INCY + vfmul.d VT0, VX1, VXC + vfmadd.d VT0, VX3, VXS, VT0 + vfmul.d VT1, VX0, VXS + vfmsub.d VT1, VX3, VXC, VT1 + vstelm.d VT0, XX, 0, 0 + add.d XX, XX, INCX + vstelm.d VT0, XX, 0, 1 + add.d XX, XX, INCX + vstelm.d VT1, YY, 0, 0 + add.d YY, YY, INCY + vstelm.d VT1, YY, 0, 1 + add.d YY, YY, INCY + ld.d t3, X, 0 * SIZE + add.d X, X, INCX + ld.d t4, X, 0 * SIZE + vinsgr2vr.d VX1, t3, 0 + vinsgr2vr.d VX1, t4, 1 + add.d X, X, INCX + ld.d t3, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t4, Y, 0 * SIZE + vinsgr2vr.d VX3, t3, 0 + vinsgr2vr.d VX3, t4, 1 + add.d Y, Y, INCY + vfmul.d VT0, VX1, VXC + vfmadd.d VT0, VX3, VXS, VT0 + vfmul.d VT1, VX0, VXS + vfmsub.d VT1, VX3, VXC, VT1 + vstelm.d VT0, XX, 0, 0 + add.d XX, XX, INCX + vstelm.d VT0, XX, 0, 1 + add.d XX, XX, INCX + vstelm.d VT1, YY, 0, 0 + add.d YY, YY, INCY + vstelm.d VT1, YY, 0, 1 + add.d YY, YY, INCY + addi.d I, I, -1 + blt $r0, I, .L221 + b .L997 + .align 3 + +.L222: // C!=0 S==0 + ld.d t1, X, 0 * SIZE + add.d X, X, INCX + ld.d t2, X, 0 * SIZE + add.d X, X, INCX + vinsgr2vr.d VX0, t1, 0 + vinsgr2vr.d VX0, t2, 1 + ld.d t1, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t2, Y, 0 * SIZE + vinsgr2vr.d VX2, t1, 0 + vinsgr2vr.d VX2, t2, 1 + add.d Y, Y, INCY + vfmul.d VT0, VX0, VXC + vfmul.d VT1, VX2, VXC + vstelm.d VT0, XX, 0, 0 + add.d XX, XX, INCX + vstelm.d VT0, XX, 0, 1 + add.d XX, XX, INCX + vstelm.d VT1, YY, 0, 0 + add.d YY, YY, INCY + vstelm.d VT1, YY, 0, 1 + add.d YY, YY, INCY + ld.d t3, X, 0 * SIZE + add.d X, X, INCX + ld.d t4, X, 0 * SIZE + add.d X, X, INCX + vinsgr2vr.d VX0, t3, 0 + vinsgr2vr.d VX0, t4, 1 + ld.d t3, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t4, Y, 0 * SIZE + vinsgr2vr.d VX2, t3, 0 + vinsgr2vr.d VX2, t4, 1 + add.d Y, Y, INCY + vfmul.d VT0, VX0, VXC + vfmul.d VT1, VX2, VXC + vstelm.d VT0, XX, 0, 0 + add.d XX, XX, INCX + vstelm.d VT0, XX, 0, 1 + add.d XX, XX, INCX + vstelm.d VT1, YY, 0, 0 + add.d YY, YY, INCY + vstelm.d VT1, YY, 0, 1 + add.d YY, YY, INCY + ld.d t1, X, 0 * SIZE + add.d X, X, INCX + ld.d t2, X, 0 * SIZE + add.d X, X, INCX + vinsgr2vr.d VX1, t1, 0 + vinsgr2vr.d VX1, t2, 1 + ld.d t1, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t2, Y, 0 * SIZE + vinsgr2vr.d VX3, t1, 0 + vinsgr2vr.d VX3, t2, 1 + add.d Y, Y, INCY + vfmul.d VT0, VX1, VXC + vfmul.d VT1, VX3, VXC + vstelm.d VT0, XX, 0, 0 + add.d XX, XX, INCX + vstelm.d VT0, XX, 0, 1 + add.d XX, XX, INCX + vstelm.d VT1, YY, 0, 0 + add.d YY, YY, INCY + vstelm.d VT1, YY, 0, 1 + add.d YY, YY, INCY + ld.d t3, X, 0 * SIZE + add.d X, X, INCX + ld.d t4, X, 0 * SIZE + add.d X, X, INCX + vinsgr2vr.d VX1, t3, 0 + vinsgr2vr.d VX1, t4, 1 + ld.d t3, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t4, Y, 0 * SIZE + vinsgr2vr.d VX3, t3, 0 + vinsgr2vr.d VX3, t4, 1 + add.d Y, Y, INCY + vfmul.d VT0, VX1, VXC + vfmul.d VT1, VX3, VXC + vstelm.d VT0, XX, 0, 0 + add.d XX, XX, INCX + vstelm.d VT0, XX, 0, 1 + add.d XX, XX, INCX + vstelm.d VT1, YY, 0, 0 + add.d YY, YY, INCY + vstelm.d VT1, YY, 0, 1 + add.d YY, YY, INCY + addi.d I, I, -1 + blt $r0, I, .L222 + b .L997 + .align 3 + +.L223: // C==0 S!=0 + ld.d t1, X, 0 * SIZE + add.d X, X, INCX + ld.d t2, X, 0 * SIZE + add.d X, X, INCX + vinsgr2vr.d VX0, t1, 0 + vinsgr2vr.d VX0, t2, 1 + ld.d t1, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t2, Y, 0 * SIZE + vinsgr2vr.d VX2, t1, 0 + vinsgr2vr.d VX2, t2, 1 + add.d Y, Y, INCY + vfmul.d VT0, VX2, VXS + vfmul.d VT1, VX0, VXS + vfsub.d VT1, VXZ, VT1 + vstelm.d VT0, XX, 0, 0 + add.d XX, XX, INCX + vstelm.d VT0, XX, 0, 1 + add.d XX, XX, INCX + vstelm.d VT1, YY, 0, 0 + add.d YY, YY, INCY + vstelm.d VT1, YY, 0, 1 + add.d YY, YY, INCY + ld.d t3, X, 0 * SIZE + add.d X, X, INCX + ld.d t4, X, 0 * SIZE + add.d X, X, INCX + vinsgr2vr.d VX0, t3, 0 + vinsgr2vr.d VX0, t4, 1 + ld.d t3, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t4, Y, 0 * SIZE + vinsgr2vr.d VX2, t3, 0 + vinsgr2vr.d VX2, t4, 1 + add.d Y, Y, INCY + vfmul.d VT0, VX2, VXS + vfmul.d VT1, VX0, VXS + vfsub.d VT1, VXZ, VT1 + vstelm.d VT0, XX, 0, 0 + add.d XX, XX, INCX + vstelm.d VT0, XX, 0, 1 + add.d XX, XX, INCX + vstelm.d VT1, YY, 0, 0 + add.d YY, YY, INCY + vstelm.d VT1, YY, 0, 1 + add.d YY, YY, INCY + ld.d t1, X, 0 * SIZE + add.d X, X, INCX + ld.d t2, X, 0 * SIZE + add.d X, X, INCX + vinsgr2vr.d VX1, t1, 0 + vinsgr2vr.d VX1, t2, 1 + ld.d t1, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t2, Y, 0 * SIZE + vinsgr2vr.d VX3, t1, 0 + vinsgr2vr.d VX3, t2, 1 + add.d Y, Y, INCY + vfmul.d VT0, VX3, VXS + vfmul.d VT1, VX0, VXS + vfsub.d VT1, VXZ, VT1 + vstelm.d VT0, XX, 0, 0 + add.d XX, XX, INCX + vstelm.d VT0, XX, 0, 1 + add.d XX, XX, INCX + vstelm.d VT1, YY, 0, 0 + add.d YY, YY, INCY + vstelm.d VT1, YY, 0, 1 + add.d YY, YY, INCY + ld.d t3, X, 0 * SIZE + add.d X, X, INCX + ld.d t4, X, 0 * SIZE + add.d X, X, INCX + vinsgr2vr.d VX1, t3, 0 + vinsgr2vr.d VX1, t4, 1 + ld.d t3, Y, 0 * SIZE + add.d Y, Y, INCY + ld.d t4, Y, 0 * SIZE + vinsgr2vr.d VX3, t3, 0 + vinsgr2vr.d VX3, t4, 1 + add.d Y, Y, INCY + vfmul.d VT0, VX3, VXS + vfmul.d VT1, VX0, VXS + vfsub.d VT1, VXZ, VT1 + vstelm.d VT0, XX, 0, 0 + add.d XX, XX, INCX + vstelm.d VT0, XX, 0, 1 + add.d XX, XX, INCX + vstelm.d VT1, YY, 0, 0 + add.d YY, YY, INCY + vstelm.d VT1, YY, 0, 1 + add.d YY, YY, INCY + addi.d I, I, -1 + blt $r0, I, .L223 + b .L997 + .align 3 + +.L224: // C==0 S==0 + vstelm.d VXZ, XX, 0, 0 + add.d XX, XX, INCX + vstelm.d VXZ, XX, 0, 1 + add.d XX, XX, INCX + vstelm.d VXZ, XX, 0, 0 + add.d XX, XX, INCX + vstelm.d VXZ, XX, 0, 1 + add.d XX, XX, INCX + vstelm.d VXZ, YY, 0, 0 + add.d YY, YY, INCY + vstelm.d VXZ, YY, 0, 1 + add.d YY, YY, INCY + vstelm.d VXZ, YY, 0, 0 + add.d YY, YY, INCY + vstelm.d VXZ, YY, 0, 1 + add.d YY, YY, INCY + vstelm.d VXZ, XX, 0, 0 + add.d XX, XX, INCX + vstelm.d VXZ, XX, 0, 1 + add.d XX, XX, INCX + vstelm.d VXZ, XX, 0, 0 + add.d XX, XX, INCX + vstelm.d VXZ, XX, 0, 1 + add.d XX, XX, INCX + vstelm.d VXZ, YY, 0, 0 + add.d YY, YY, INCY + vstelm.d VXZ, YY, 0, 1 + add.d YY, YY, INCY + vstelm.d VXZ, YY, 0, 0 + add.d YY, YY, INCY + vstelm.d VXZ, YY, 0, 1 + add.d YY, YY, INCY + addi.d I, I, -1 + blt $r0, I, .L224 + b .L997 + .align 3 + +.L997: + andi I, N, 7 + bge $r0, I, .L999 + .align 3 + +.L998: + fld.d $f12, X, 0 * SIZE + fld.d $f13, Y, 0 * SIZE + fmul.d $f10, $f12, C + fmadd.d $f10, $f13, S, $f10 + fst.d $f10, X, 0 * SIZE + addi.d I, I, -1 + fmul.d $f20, $f12, S + fmsub.d $f20, $f13, C, $f20 + fst.d $f20, Y, 0 * SIZE + add.d X, X, INCX + add.d Y, Y, INCY + blt $r0, I, .L998 + .align 3 + +.L999: + move $r4, $r12 + jirl $r0, $r1, 0x0 + .align 3 + + EPILOGUE \ No newline at end of file diff --git a/kernel/loongarch64/srot_lasx.S b/kernel/loongarch64/srot_lasx.S new file mode 100644 index 000000000..9aeb4dcf5 --- /dev/null +++ b/kernel/loongarch64/srot_lasx.S @@ -0,0 +1,863 @@ +#define ASSEMBLER + +#include "common.h" +#define N $r4 +#define X $r5 +#define INCX $r6 +#define Y $r7 +#define INCY $r8 +#define C $f0 +#define S $f1 + +#define I $r12 +#define TEMP $r13 +#define t1 $r14 +#define t2 $r16 +#define t3 $r15 +#define t4 $r17 +#define XX $r18 +#define YY $r19 +#define a1 $f12 +#define VX0 $xr8 +#define VX1 $xr20 +#define VX2 $xr21 +#define VX3 $xr22 +#define VT0 $xr10 +#define VT1 $xr18 +#define VXC $xr23 +#define VXS $xr9 +#define VXZ $xr19 + + PROLOGUE + + bge $r0, N, .L999 + li.d TEMP, 1 + movgr2fr.d a1, $r0 + ffint.s.l a1, a1 + slli.d TEMP, TEMP, BASE_SHIFT + slli.d INCX, INCX, BASE_SHIFT + slli.d INCY, INCY, BASE_SHIFT + movfr2gr.s t1, C + xvreplgr2vr.w VXC, t1 + movfr2gr.s t2, S + xvreplgr2vr.w VXS, t2 + movfr2gr.s t3, a1 + xvreplgr2vr.w VXZ, t3 + srai.d I, N, 3 + bne INCX, TEMP, .L20 + bne INCY, TEMP, .L12 // INCX==1 and INCY!=1 + b .L11 // INCX==1 and INCY==1 +.L20: + bne INCY, TEMP, .L22 // INCX!=1 and INCY!=1 + b .L21 // INCX!=1 and INCY==1 + +.L11: + bge $r0, I, .L997 + fcmp.ceq.s $fcc0, C, a1 + bcnez $fcc0, .L110 + fcmp.ceq.s $fcc0, S, a1 + bcnez $fcc0, .L112 // C!=0 S==0 + b .L111 // C!=0 S!=0 + .align 3 + +.L110: + fcmp.ceq.s $fcc0, S, a1 + bcnez $fcc0, .L114 // C==0 S==0 + b .L113 // C==0 S!=0 + .align 3 + +.L111: // C!=0 S!=0 + xvld VX0, X, 0 * SIZE + xvld VX2, Y, 0 * SIZE + xvfmul.s VT0, VX0, VXC + xvfmadd.s VT0, VX2, VXS, VT0 + xvfmul.s VT1, VX0, VXS + xvfmsub.s VT1, VX2, VXC, VT1 + xvst VT0, X, 0 * SIZE + xvst VT1, Y, 0 * SIZE + addi.d X, X, 8 * SIZE + addi.d Y, Y, 8 * SIZE + addi.d I, I, -1 + blt $r0, I, .L111 + b .L997 + .align 3 + +.L112: // C!=0 S==0 + xvld VX0, X, 0 * SIZE + xvld VX2, Y, 0 * SIZE + xvfmul.s VT0, VX0, VXC + xvfmul.s VT1, VX2, VXC + xvst VT0, X, 0 * SIZE + xvst VT1, Y, 0 * SIZE + addi.d X, X, 8 * SIZE + addi.d Y, Y, 8 * SIZE + addi.d I, I, -1 + blt $r0, I, .L112 + b .L997 + .align 3 + +.L113: // C==0 S!=0 + xvld VX0, X, 0 * SIZE + xvld VX2, Y, 0 * SIZE + xvfmul.s VT0, VX2, VXS + xvfmul.s VT1, VX0, VXS + xvfsub.s VT1, VXZ, VT1 + xvst VT0, X, 0 * SIZE + xvst VT1, Y, 0 * SIZE + addi.d X, X, 8 * SIZE + addi.d Y, Y, 8 * SIZE + addi.d I, I, -1 + blt $r0, I, .L113 + b .L997 + .align 3 + +.L114: // C==0 S==0 + xvst VXZ, X, 0 * SIZE + xvst VXZ, Y, 0 * SIZE + addi.d X, X, 8 * SIZE + addi.d Y, Y, 8 * SIZE + addi.d I, I, -1 + blt $r0, I, .L114 + b .L997 + .align 3 + +.L12: // INCX==1 and INCY!=1 + bge $r0, I, .L997 + move YY, Y + move XX, X + fcmp.ceq.s $fcc0, C, a1 + bcnez $fcc0, .L120 + fcmp.ceq.s $fcc0, S, a1 + bcnez $fcc0, .L122 // C!=0 S==0 + b .L121 // C!=0 S!=0 + .align 3 + +.L120: + fcmp.ceq.s $fcc0, S, a1 + bcnez $fcc0, .L124 // C==0 S==0 + b .L123 // C==0 S!=0 + .align 3 + +.L121: // C!=0 S!=0 + xvld VX0, X, 0 * SIZE + ld.w t1, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t2, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t3, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t4, Y, 0 * SIZE + add.d Y, Y, INCY + xvinsgr2vr.w VX2, t1, 0 + xvinsgr2vr.w VX2, t2, 1 + xvinsgr2vr.w VX2, t3, 2 + xvinsgr2vr.w VX2, t4, 3 + ld.w t1, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t2, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t3, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t4, Y, 0 * SIZE + xvinsgr2vr.w VX2, t1, 4 + xvinsgr2vr.w VX2, t2, 5 + xvinsgr2vr.w VX2, t3, 6 + xvinsgr2vr.w VX2, t4, 7 + add.d Y, Y, INCY + xvfmul.s VT0, VX0, VXC + xvfmadd.s VT0, VX2, VXS, VT0 + xvfmul.s VT1, VX0, VXS + xvfmsub.s VT1, VX2, VXC, VT1 + xvst VT0, X, 0 * SIZE + xvstelm.w VT1, YY, 0, 0 + add.d YY, YY, INCY + xvstelm.w VT1, YY, 0, 1 + add.d YY, YY, INCY + xvstelm.w VT1, YY, 0, 2 + add.d YY, YY, INCY + xvstelm.w VT1, YY, 0, 3 + add.d YY, YY, INCY + xvstelm.w VT1, YY, 0, 4 + add.d YY, YY, INCY + xvstelm.w VT1, YY, 0, 5 + add.d YY, YY, INCY + xvstelm.w VT1, YY, 0, 6 + add.d YY, YY, INCY + xvstelm.w VT1, YY, 0, 7 + add.d YY, YY, INCY + addi.d X, X, 8 * SIZE + addi.d I, I, -1 + blt $r0, I, .L121 + b .L997 + .align 3 + +.L122: // C!=0 S==0 + xvld VX0, X, 0 * SIZE + ld.w t1, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t2, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t3, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t4, Y, 0 * SIZE + add.d Y, Y, INCY + xvinsgr2vr.w VX2, t1, 0 + xvinsgr2vr.w VX2, t2, 1 + xvinsgr2vr.w VX2, t3, 2 + xvinsgr2vr.w VX2, t4, 3 + ld.w t1, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t2, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t3, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t4, Y, 0 * SIZE + xvinsgr2vr.w VX2, t1, 4 + xvinsgr2vr.w VX2, t2, 5 + xvinsgr2vr.w VX2, t3, 6 + xvinsgr2vr.w VX2, t4, 7 + add.d Y, Y, INCY + xvfmul.s VT0, VX0, VXC + xvfmul.s VT1, VX2, VXC + xvst VT0, X, 0 * SIZE + xvstelm.w VT1, YY, 0, 0 + add.d YY, YY, INCY + xvstelm.w VT1, YY, 0, 1 + add.d YY, YY, INCY + xvstelm.w VT1, YY, 0, 2 + add.d YY, YY, INCY + xvstelm.w VT1, YY, 0, 3 + add.d YY, YY, INCY + xvstelm.w VT1, YY, 0, 4 + add.d YY, YY, INCY + xvstelm.w VT1, YY, 0, 5 + add.d YY, YY, INCY + xvstelm.w VT1, YY, 0, 6 + add.d YY, YY, INCY + xvstelm.w VT1, YY, 0, 7 + add.d YY, YY, INCY + addi.d X, X, 8 * SIZE + addi.d I, I, -1 + blt $r0, I, .L122 + b .L997 + .align 3 + +.L123: // C==0 S!=0 + xvld VX0, X, 0 * SIZE + ld.w t1, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t2, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t3, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t4, Y, 0 * SIZE + add.d Y, Y, INCY + xvinsgr2vr.w VX2, t1, 0 + xvinsgr2vr.w VX2, t2, 1 + xvinsgr2vr.w VX2, t3, 2 + xvinsgr2vr.w VX2, t4, 3 + ld.w t1, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t2, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t3, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t4, Y, 0 * SIZE + xvinsgr2vr.w VX2, t1, 4 + xvinsgr2vr.w VX2, t2, 5 + xvinsgr2vr.w VX2, t3, 6 + xvinsgr2vr.w VX2, t4, 7 + add.d Y, Y, INCY + xvfmul.s VT0, VX2, VXS + xvfmul.s VT1, VX0, VXS + xvfsub.s VT1, VXZ, VT1 + xvst VT0, X, 0 * SIZE + xvstelm.w VT1, YY, 0, 0 + add.d YY, YY, INCY + xvstelm.w VT1, YY, 0, 1 + add.d YY, YY, INCY + xvstelm.w VT1, YY, 0, 2 + add.d YY, YY, INCY + xvstelm.w VT1, YY, 0, 3 + add.d YY, YY, INCY + xvstelm.w VT1, YY, 0, 4 + add.d YY, YY, INCY + xvstelm.w VT1, YY, 0, 5 + add.d YY, YY, INCY + xvstelm.w VT1, YY, 0, 6 + add.d YY, YY, INCY + xvstelm.w VT1, YY, 0, 7 + add.d YY, YY, INCY + addi.d X, X, 8 * SIZE + addi.d I, I, -1 + blt $r0, I, .L123 + b .L997 + .align 3 + +.L124: // C==0 S==0 + xvst VXZ, X, 0 * SIZE + xvstelm.w VXZ, YY, 0, 0 + add.d YY, YY, INCY + xvstelm.w VXZ, YY, 0, 1 + add.d YY, YY, INCY + xvstelm.w VXZ, YY, 0, 2 + add.d YY, YY, INCY + xvstelm.w VXZ, YY, 0, 3 + add.d YY, YY, INCY + xvstelm.w VXZ, YY, 0, 4 + add.d YY, YY, INCY + xvstelm.w VXZ, YY, 0, 5 + add.d YY, YY, INCY + xvstelm.w VXZ, YY, 0, 6 + add.d YY, YY, INCY + xvstelm.w VXZ, YY, 0, 7 + add.d YY, YY, INCY + addi.d I, I, -1 + blt $r0, I, .L124 + b .L997 + .align 3 + +.L21:// INCX!=1 and INCY==1 + bge $r0, I, .L997 + move XX, X + fcmp.ceq.s $fcc0, C, a1 + bcnez $fcc0, .L210 + fcmp.ceq.s $fcc0, S, a1 + bcnez $fcc0, .L212 // C!=0 S==0 + b .L211 // C!=0 S!=0 + .align 3 + +.L210: + fcmp.ceq.s $fcc0, S, a1 + bcnez $fcc0, .L214 // C==0 S==0 + b .L213 // C==0 S!=0 + .align 3 + +.L211: // C!=0 S!=0 + xvld VX2, Y, 0 * SIZE + ld.w t1, X, 0 * SIZE + add.d X, X, INCX + ld.w t2, X, 0 * SIZE + add.d X, X, INCX + ld.w t3, X, 0 * SIZE + add.d X, X, INCX + ld.w t4, X, 0 * SIZE + add.d X, X, INCX + xvinsgr2vr.w VX0, t1, 0 + xvinsgr2vr.w VX0, t2, 1 + xvinsgr2vr.w VX0, t3, 2 + xvinsgr2vr.w VX0, t4, 3 + ld.w t1, X, 0 * SIZE + add.d X, X, INCX + ld.w t2, X, 0 * SIZE + add.d X, X, INCX + ld.w t3, X, 0 * SIZE + add.d X, X, INCX + ld.w t4, X, 0 * SIZE + xvinsgr2vr.w VX0, t1, 4 + xvinsgr2vr.w VX0, t2, 5 + xvinsgr2vr.w VX0, t3, 6 + xvinsgr2vr.w VX0, t4, 7 + add.d X, X, INCX + xvfmul.s VT0, VXC, VX0 + xvfmadd.s VT0, VX2, VXS, VT0 + xvfmul.s VT1, VX0, VXS + xvfmsub.s VT1, VX2, VXC, VT1 + xvstelm.w VT0, XX, 0, 0 + add.d XX, XX, INCX + xvstelm.w VT0, XX, 0, 1 + add.d XX, XX, INCX + xvstelm.w VT0, XX, 0, 2 + add.d XX, XX, INCX + xvstelm.w VT0, XX, 0, 3 + add.d XX, XX, INCX + xvstelm.w VT0, XX, 0, 4 + add.d XX, XX, INCX + xvstelm.w VT0, XX, 0, 5 + add.d XX, XX, INCX + xvstelm.w VT0, XX, 0, 6 + add.d XX, XX, INCX + xvstelm.w VT0, XX, 0, 7 + add.d XX, XX, INCX + xvst VT1, Y, 0 * SIZE + addi.d Y, Y, 8 * SIZE + addi.d I, I, -1 + blt $r0, I, .L211 + b .L997 + .align 3 + +.L212: // C!=0 S==0 + xvld VX2, Y, 0 * SIZE + ld.w t1, X, 0 * SIZE + add.d X, X, INCX + ld.w t2, X, 0 * SIZE + add.d X, X, INCX + ld.w t3, X, 0 * SIZE + add.d X, X, INCX + ld.w t4, X, 0 * SIZE + add.d X, X, INCX + xvinsgr2vr.w VX0, t1, 0 + xvinsgr2vr.w VX0, t2, 1 + xvinsgr2vr.w VX0, t3, 2 + xvinsgr2vr.w VX0, t4, 3 + ld.w t1, X, 0 * SIZE + add.d X, X, INCX + ld.w t2, X, 0 * SIZE + add.d X, X, INCX + ld.w t3, X, 0 * SIZE + add.d X, X, INCX + ld.w t4, X, 0 * SIZE + xvinsgr2vr.w VX0, t1, 4 + xvinsgr2vr.w VX0, t2, 5 + xvinsgr2vr.w VX0, t3, 6 + xvinsgr2vr.w VX0, t4, 7 + add.d X, X, INCX + xvfmul.s VT0, VXC, VX0 + xvfmul.s VT1, VX2, VXC + xvstelm.w VT0, XX, 0, 0 + add.d XX, XX, INCX + xvstelm.w VT0, XX, 0, 1 + add.d XX, XX, INCX + xvstelm.w VT0, XX, 0, 2 + add.d XX, XX, INCX + xvstelm.w VT0, XX, 0, 3 + add.d XX, XX, INCX + xvstelm.w VT0, XX, 0, 4 + add.d XX, XX, INCX + xvstelm.w VT0, XX, 0, 5 + add.d XX, XX, INCX + xvstelm.w VT0, XX, 0, 6 + add.d XX, XX, INCX + xvstelm.w VT0, XX, 0, 7 + add.d XX, XX, INCX + xvst VT1, Y, 0 * SIZE + addi.d Y, Y, 8 * SIZE + addi.d I, I, -1 + blt $r0, I, .L212 + b .L997 + .align 3 + +.L213: // C==0 S!=0 + xvld VX2, Y, 0 * SIZE + ld.w t1, X, 0 * SIZE + add.d X, X, INCX + ld.w t2, X, 0 * SIZE + add.d X, X, INCX + ld.w t3, X, 0 * SIZE + add.d X, X, INCX + ld.w t4, X, 0 * SIZE + add.d X, X, INCX + xvinsgr2vr.w VX0, t1, 0 + xvinsgr2vr.w VX0, t2, 1 + xvinsgr2vr.w VX0, t3, 2 + xvinsgr2vr.w VX0, t4, 3 + ld.w t1, X, 0 * SIZE + add.d X, X, INCX + ld.w t2, X, 0 * SIZE + add.d X, X, INCX + ld.w t3, X, 0 * SIZE + add.d X, X, INCX + ld.w t4, X, 0 * SIZE + xvinsgr2vr.w VX0, t1, 4 + xvinsgr2vr.w VX0, t2, 5 + xvinsgr2vr.w VX0, t3, 6 + xvinsgr2vr.w VX0, t4, 7 + add.d X, X, INCX + xvfmul.s VT0, VXS, VX2 + xvfmul.s VT1, VXS, VX0 + xvfsub.s VT1, VXZ, VT1 + xvstelm.w VT0, XX, 0, 0 + add.d XX, XX, INCX + xvstelm.w VT0, XX, 0, 1 + add.d XX, XX, INCX + xvstelm.w VT0, XX, 0, 2 + add.d XX, XX, INCX + xvstelm.w VT0, XX, 0, 3 + add.d XX, XX, INCX + xvstelm.w VT0, XX, 0, 4 + add.d XX, XX, INCX + xvstelm.w VT0, XX, 0, 5 + add.d XX, XX, INCX + xvstelm.w VT0, XX, 0, 6 + add.d XX, XX, INCX + xvstelm.w VT0, XX, 0, 7 + add.d XX, XX, INCX + xvst VT1, Y, 0 * SIZE + addi.d Y, Y, 8 * SIZE + addi.d I, I, -1 + blt $r0, I, .L213 + b .L997 + .align 3 + +.L214: // C==0 S==0 + xvstelm.w VXZ, XX, 0, 0 + add.d XX, XX, INCX + xvstelm.w VXZ, XX, 0, 1 + add.d XX, XX, INCX + xvstelm.w VXZ, XX, 0, 2 + add.d XX, XX, INCX + xvstelm.w VXZ, XX, 0, 3 + add.d XX, XX, INCX + xvst VT1, Y, 0 * SIZE + xvstelm.w VXZ, XX, 0, 4 + add.d XX, XX, INCX + xvstelm.w VXZ, XX, 0, 5 + add.d XX, XX, INCX + xvstelm.w VXZ, XX, 0, 6 + add.d XX, XX, INCX + xvstelm.w VXZ, XX, 0, 7 + add.d XX, XX, INCX + addi.d Y, Y, 8 * SIZE + addi.d I, I, -1 + blt $r0, I, .L211 + b .L997 + .align 3 + +.L22: + bge $r0, I, .L997 + move YY, Y + move XX, X + fcmp.ceq.s $fcc0, C, a1 + bcnez $fcc0, .L220 + fcmp.ceq.s $fcc0, S, a1 + bcnez $fcc0, .L222 // C!=0 S==0 + b .L221 // C!=0 S!=0 + .align 3 + +.L220: + fcmp.ceq.s $fcc0, S, a1 + bcnez $fcc0, .L224 // C==0 S==0 + b .L223 // C==0 S!=0 + .align 3 + +.L221: // C!=0 S!=0 + ld.w t1, X, 0 * SIZE + add.d X, X, INCX + ld.w t2, X, 0 * SIZE + add.d X, X, INCX + ld.w t3, X, 0 * SIZE + add.d X, X, INCX + ld.w t4, X, 0 * SIZE + add.d X, X, INCX + xvinsgr2vr.w VX0, t1, 0 + xvinsgr2vr.w VX0, t2, 1 + xvinsgr2vr.w VX0, t3, 2 + xvinsgr2vr.w VX0, t4, 3 + ld.w t1, X, 0 * SIZE + add.d X, X, INCX + ld.w t2, X, 0 * SIZE + add.d X, X, INCX + ld.w t3, X, 0 * SIZE + add.d X, X, INCX + ld.w t4, X, 0 * SIZE + add.d X, X, INCX + xvinsgr2vr.w VX0, t1, 4 + xvinsgr2vr.w VX0, t2, 5 + xvinsgr2vr.w VX0, t3, 6 + xvinsgr2vr.w VX0, t4, 7 + ld.w t1, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t2, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t3, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t4, Y, 0 * SIZE + add.d Y, Y, INCY + xvinsgr2vr.w VX2, t1, 0 + xvinsgr2vr.w VX2, t2, 1 + xvinsgr2vr.w VX2, t3, 2 + xvinsgr2vr.w VX2, t4, 3 + ld.w t1, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t2, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t3, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t4, Y, 0 * SIZE + xvinsgr2vr.w VX2, t1, 4 + xvinsgr2vr.w VX2, t2, 5 + xvinsgr2vr.w VX2, t3, 6 + xvinsgr2vr.w VX2, t4, 7 + add.d Y, Y, INCY + xvfmul.s VT0, VX0, VXC + xvfmadd.s VT0, VX2, VXS, VT0 + xvfmul.s VT1, VX0, VXS + xvfmsub.s VT1, VX2, VXC, VT1 + xvstelm.w VT0, XX, 0, 0 + add.d XX, XX, INCX + xvstelm.w VT0, XX, 0, 1 + add.d XX, XX, INCX + xvstelm.w VT0, XX, 0, 2 + add.d XX, XX, INCX + xvstelm.w VT0, XX, 0, 3 + add.d XX, XX, INCX + xvstelm.w VT0, XX, 0, 4 + add.d XX, XX, INCX + xvstelm.w VT0, XX, 0, 5 + add.d XX, XX, INCX + xvstelm.w VT0, XX, 0, 6 + add.d XX, XX, INCX + xvstelm.w VT0, XX, 0, 7 + add.d XX, XX, INCX + xvstelm.w VT1, YY, 0, 0 + add.d YY, YY, INCY + xvstelm.w VT1, YY, 0, 1 + add.d YY, YY, INCY + xvstelm.w VT1, YY, 0, 2 + add.d YY, YY, INCY + xvstelm.w VT1, YY, 0, 3 + add.d YY, YY, INCY + xvstelm.w VT1, YY, 0, 4 + add.d YY, YY, INCY + xvstelm.w VT1, YY, 0, 5 + add.d YY, YY, INCY + xvstelm.w VT1, YY, 0, 6 + add.d YY, YY, INCY + xvstelm.w VT1, YY, 0, 7 + add.d YY, YY, INCY + addi.d I, I, -1 + blt $r0, I, .L221 + b .L997 + .align 3 + +.L222: // C!=0 S==0 + ld.w t1, X, 0 * SIZE + add.d X, X, INCX + ld.w t2, X, 0 * SIZE + add.d X, X, INCX + ld.w t3, X, 0 * SIZE + add.d X, X, INCX + ld.w t4, X, 0 * SIZE + add.d X, X, INCX + xvinsgr2vr.w VX0, t1, 0 + xvinsgr2vr.w VX0, t2, 1 + xvinsgr2vr.w VX0, t3, 2 + xvinsgr2vr.w VX0, t4, 3 + ld.w t1, X, 0 * SIZE + add.d X, X, INCX + ld.w t2, X, 0 * SIZE + add.d X, X, INCX + ld.w t3, X, 0 * SIZE + add.d X, X, INCX + ld.w t4, X, 0 * SIZE + add.d X, X, INCX + xvinsgr2vr.w VX0, t1, 4 + xvinsgr2vr.w VX0, t2, 5 + xvinsgr2vr.w VX0, t3, 6 + xvinsgr2vr.w VX0, t4, 7 + ld.w t1, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t2, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t3, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t4, Y, 0 * SIZE + add.d Y, Y, INCY + xvinsgr2vr.w VX2, t1, 0 + xvinsgr2vr.w VX2, t2, 1 + xvinsgr2vr.w VX2, t3, 2 + xvinsgr2vr.w VX2, t4, 3 + ld.w t1, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t2, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t3, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t4, Y, 0 * SIZE + xvinsgr2vr.w VX2, t1, 4 + xvinsgr2vr.w VX2, t2, 5 + xvinsgr2vr.w VX2, t3, 6 + xvinsgr2vr.w VX2, t4, 7 + add.d Y, Y, INCY + xvfmul.s VT0, VX0, VXC + xvfmul.s VT1, VX2, VXC + xvstelm.w VT0, XX, 0, 0 + add.d XX, XX, INCX + xvstelm.w VT0, XX, 0, 1 + add.d XX, XX, INCX + xvstelm.w VT0, XX, 0, 2 + add.d XX, XX, INCX + xvstelm.w VT0, XX, 0, 3 + add.d XX, XX, INCX + xvstelm.w VT0, XX, 0, 4 + add.d XX, XX, INCX + xvstelm.w VT0, XX, 0, 5 + add.d XX, XX, INCX + xvstelm.w VT0, XX, 0, 6 + add.d XX, XX, INCX + xvstelm.w VT0, XX, 0, 7 + add.d XX, XX, INCX + xvstelm.w VT1, YY, 0, 0 + add.d YY, YY, INCY + xvstelm.w VT1, YY, 0, 1 + add.d YY, YY, INCY + xvstelm.w VT1, YY, 0, 2 + add.d YY, YY, INCY + xvstelm.w VT1, YY, 0, 3 + add.d YY, YY, INCY + xvstelm.w VT1, YY, 0, 4 + add.d YY, YY, INCY + xvstelm.w VT1, YY, 0, 5 + add.d YY, YY, INCY + xvstelm.w VT1, YY, 0, 6 + add.d YY, YY, INCY + xvstelm.w VT1, YY, 0, 7 + add.d YY, YY, INCY + addi.d I, I, -1 + blt $r0, I, .L222 + b .L997 + .align 3 + +.L223: // C==0 S!=0 + ld.w t1, X, 0 * SIZE + add.d X, X, INCX + ld.w t2, X, 0 * SIZE + add.d X, X, INCX + ld.w t3, X, 0 * SIZE + add.d X, X, INCX + ld.w t4, X, 0 * SIZE + add.d X, X, INCX + xvinsgr2vr.w VX0, t1, 0 + xvinsgr2vr.w VX0, t2, 1 + xvinsgr2vr.w VX0, t3, 2 + xvinsgr2vr.w VX0, t4, 3 + ld.w t1, X, 0 * SIZE + add.d X, X, INCX + ld.w t2, X, 0 * SIZE + add.d X, X, INCX + ld.w t3, X, 0 * SIZE + add.d X, X, INCX + ld.w t4, X, 0 * SIZE + add.d X, X, INCX + xvinsgr2vr.w VX0, t1, 4 + xvinsgr2vr.w VX0, t2, 5 + xvinsgr2vr.w VX0, t3, 6 + xvinsgr2vr.w VX0, t4, 7 + ld.w t1, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t2, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t3, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t4, Y, 0 * SIZE + add.d Y, Y, INCY + xvinsgr2vr.w VX2, t1, 0 + xvinsgr2vr.w VX2, t2, 1 + xvinsgr2vr.w VX2, t3, 2 + xvinsgr2vr.w VX2, t4, 3 + ld.w t1, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t2, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t3, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t4, Y, 0 * SIZE + xvinsgr2vr.w VX2, t1, 4 + xvinsgr2vr.w VX2, t2, 5 + xvinsgr2vr.w VX2, t3, 6 + xvinsgr2vr.w VX2, t4, 7 + add.d Y, Y, INCY + xvfmul.s VT0, VX2, VXS + xvfmul.s VT1, VX0, VXS + xvfsub.s VT1, VXZ, VT1 + xvstelm.w VT0, XX, 0, 0 + add.d XX, XX, INCX + xvstelm.w VT0, XX, 0, 1 + add.d XX, XX, INCX + xvstelm.w VT0, XX, 0, 2 + add.d XX, XX, INCX + xvstelm.w VT0, XX, 0, 3 + add.d XX, XX, INCX + xvstelm.w VT0, XX, 0, 4 + add.d XX, XX, INCX + xvstelm.w VT0, XX, 0, 5 + add.d XX, XX, INCX + xvstelm.w VT0, XX, 0, 6 + add.d XX, XX, INCX + xvstelm.w VT0, XX, 0, 7 + add.d XX, XX, INCX + xvstelm.w VT1, YY, 0, 0 + add.d YY, YY, INCY + xvstelm.w VT1, YY, 0, 1 + add.d YY, YY, INCY + xvstelm.w VT1, YY, 0, 2 + add.d YY, YY, INCY + xvstelm.w VT1, YY, 0, 3 + add.d YY, YY, INCY + xvstelm.w VT1, YY, 0, 4 + add.d YY, YY, INCY + xvstelm.w VT1, YY, 0, 5 + add.d YY, YY, INCY + xvstelm.w VT1, YY, 0, 6 + add.d YY, YY, INCY + xvstelm.w VT1, YY, 0, 7 + add.d YY, YY, INCY + addi.d I, I, -1 + blt $r0, I, .L223 + b .L997 + .align 3 + +.L224: // C==0 S==0 + xvstelm.w VXZ, XX, 0, 0 + add.d XX, XX, INCX + xvstelm.w VXZ, XX, 0, 1 + add.d XX, XX, INCX + xvstelm.w VXZ, XX, 0, 2 + add.d XX, XX, INCX + xvstelm.w VXZ, XX, 0, 3 + add.d XX, XX, INCX + xvstelm.w VXZ, YY, 0, 0 + add.d YY, YY, INCY + xvstelm.w VXZ, YY, 0, 1 + add.d YY, YY, INCY + xvstelm.w VXZ, YY, 0, 2 + add.d YY, YY, INCY + xvstelm.w VXZ, YY, 0, 3 + add.d YY, YY, INCY + xvstelm.w VXZ, XX, 0, 4 + add.d XX, XX, INCX + xvstelm.w VXZ, XX, 0, 5 + add.d XX, XX, INCX + xvstelm.w VXZ, XX, 0, 6 + add.d XX, XX, INCX + xvstelm.w VXZ, XX, 0, 7 + add.d XX, XX, INCX + xvstelm.w VXZ, YY, 0, 4 + add.d YY, YY, INCY + xvstelm.w VXZ, YY, 0, 5 + add.d YY, YY, INCY + xvstelm.w VXZ, YY, 0, 6 + add.d YY, YY, INCY + xvstelm.w VXZ, YY, 0, 7 + add.d YY, YY, INCY + addi.d I, I, -1 + blt $r0, I, .L224 + b .L997 + .align 3 + +.L997: + andi I, N, 7 + bge $r0, I, .L999 + .align 3 + +.L998: + fld.s $f12, X, 0 * SIZE + fld.s $f13, Y, 0 * SIZE + fmul.s $f10, $f12, C + fmadd.s $f10, $f13, S, $f10 + fst.s $f10, X, 0 * SIZE + addi.d I, I, -1 + fmul.s $f20, $f12, S + fmsub.s $f20, $f13, C, $f20 + fst.s $f20, Y, 0 * SIZE + add.d X, X, INCX + add.d Y, Y, INCY + blt $r0, I, .L998 + .align 3 + +.L999: + move $r4, $r12 + jirl $r0, $r1, 0x0 + .align 3 + + EPILOGUE \ No newline at end of file diff --git a/kernel/loongarch64/srot_lsx.S b/kernel/loongarch64/srot_lsx.S new file mode 100644 index 000000000..8822b58e4 --- /dev/null +++ b/kernel/loongarch64/srot_lsx.S @@ -0,0 +1,927 @@ +#define ASSEMBLER + +#include "common.h" +#define N $r4 +#define X $r5 +#define INCX $r6 +#define Y $r7 +#define INCY $r8 +#define C $f0 +#define S $f1 + +#define I $r12 +#define TEMP $r13 +#define t1 $r14 +#define t2 $r16 +#define t3 $r15 +#define t4 $r17 +#define XX $r18 +#define YY $r19 +#define a1 $f12 +#define VX0 $vr8 +#define VX1 $vr20 +#define VX2 $vr21 +#define VX3 $vr22 +#define VT0 $vr10 +#define VT1 $vr18 +#define VXC $vr23 +#define VXS $vr9 +#define VXZ $vr19 + + PROLOGUE + + bge $r0, N, .L999 + li.d TEMP, 1 + movgr2fr.d a1, $r0 + ffint.s.l a1, a1 + slli.d TEMP, TEMP, BASE_SHIFT + slli.d INCX, INCX, BASE_SHIFT + slli.d INCY, INCY, BASE_SHIFT + movfr2gr.s t1, C + vreplgr2vr.w VXC, t1 + movfr2gr.s t2, S + vreplgr2vr.w VXS, t2 + movfr2gr.s t3, a1 + vreplgr2vr.w VXZ, t3 + srai.d I, N, 3 + bne INCX, TEMP, .L20 + bne INCY, TEMP, .L12 // INCX==1 and INCY!=1 + b .L11 // INCX==1 and INCY==1 +.L20: + bne INCY, TEMP, .L22 // INCX!=1 and INCY!=1 + b .L21 // INCX!=1 and INCY==1 + +.L11: + bge $r0, I, .L997 + fcmp.ceq.s $fcc0, C, a1 + bcnez $fcc0, .L110 + fcmp.ceq.s $fcc0, S, a1 + bcnez $fcc0, .L112 // C!=0 S==0 + b .L111 // C!=0 S!=0 + .align 3 + +.L110: + fcmp.ceq.s $fcc0, S, a1 + bcnez $fcc0, .L114 // C==0 S==0 + b .L113 // C==0 S!=0 + .align 3 + +.L111: // C!=0 S!=0 + vld VX0, X, 0 * SIZE + vld VX2, Y, 0 * SIZE + vld VX1, X, 4 * SIZE + vld VX3, Y, 4 * SIZE + vfmul.s VT0, VX0, VXC + vfmadd.s VT0, VX2, VXS, VT0 + vfmul.s VT1, VX0, VXS + vfmsub.s VT1, VX2, VXC, VT1 + vst VT0, X, 0 * SIZE + vst VT1, Y, 0 * SIZE + vfmul.s VT0, VX1, VXC + vfmadd.s VT0, VX3, VXS, VT0 + vfmul.s VT1, VX1, VXS + vfmsub.s VT1, VX3, VXC, VT1 + vst VT0, X, 4 * SIZE + vst VT1, Y, 4 * SIZE + addi.d X, X, 8 * SIZE + addi.d Y, Y, 8 * SIZE + addi.d I, I, -1 + blt $r0, I, .L111 + b .L997 + .align 3 + +.L112: // C!=0 S==0 + vld VX0, X, 0 * SIZE + vld VX2, Y, 0 * SIZE + vld VX1, X, 4 * SIZE + vld VX3, Y, 4 * SIZE + vfmul.s VT0, VX0, VXC + vfmul.s VT1, VX2, VXC + vst VT0, X, 0 * SIZE + vst VT1, Y, 0 * SIZE + vfmul.s VT0, VX1, VXC + vfmul.s VT1, VX3, VXC + vst VT0, X, 4 * SIZE + vst VT1, Y, 4 * SIZE + addi.d X, X, 8 * SIZE + addi.d Y, Y, 8 * SIZE + addi.d I, I, -1 + blt $r0, I, .L112 + b .L997 + .align 3 + +.L113: // C==0 S!=0 + vld VX0, X, 0 * SIZE + vld VX2, Y, 0 * SIZE + vld VX1, X, 4 * SIZE + vld VX3, Y, 4 * SIZE + vfmul.s VT0, VX2, VXS + vfmul.s VT1, VX0, VXS + vfsub.s VT1, VXZ, VT1 + vst VT0, X, 0 * SIZE + vst VT1, Y, 0 * SIZE + vfmul.s VT0, VX3, VXS + vfmul.s VT1, VX1, VXS + vfsub.s VT1, VXZ, VT1 + vst VT0, X, 4 * SIZE + vst VT1, Y, 4 * SIZE + addi.d X, X, 8 * SIZE + addi.d Y, Y, 8 * SIZE + addi.d I, I, -1 + blt $r0, I, .L113 + b .L997 + .align 3 + +.L114: // C==0 S==0 + vst VXZ, X, 0 * SIZE + vst VXZ, Y, 0 * SIZE + vst VXZ, X, 4 * SIZE + vst VXZ, Y, 4 * SIZE + addi.d X, X, 8 * SIZE + addi.d Y, Y, 8 * SIZE + addi.d I, I, -1 + blt $r0, I, .L114 + b .L997 + .align 3 + +.L12: // INCX==1 and INCY!=1 + bge $r0, I, .L997 + move YY, Y + move XX, X + fcmp.ceq.s $fcc0, C, a1 + bcnez $fcc0, .L120 + fcmp.ceq.s $fcc0, S, a1 + bcnez $fcc0, .L122 // C!=0 S==0 + b .L121 // C!=0 S!=0 + .align 3 + +.L120: + fcmp.ceq.s $fcc0, S, a1 + bcnez $fcc0, .L124 // C==0 S==0 + b .L123 // C==0 S!=0 + .align 3 + +.L121: // C!=0 S!=0 + vld VX0, X, 0 * SIZE + ld.w t1, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t2, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t3, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t4, Y, 0 * SIZE + vinsgr2vr.w VX2, t1, 0 + vinsgr2vr.w VX2, t2, 1 + vinsgr2vr.w VX2, t3, 2 + vinsgr2vr.w VX2, t4, 3 + add.d Y, Y, INCY + vfmul.s VT0, VX0, VXC + vfmadd.s VT0, VX2, VXS, VT0 + vfmul.s VT1, VX0, VXS + vfmsub.s VT1, VX2, VXC, VT1 + vst VT0, X, 0 * SIZE + vstelm.w VT1, YY, 0, 0 + add.d YY, YY, INCY + vstelm.w VT1, YY, 0, 1 + add.d YY, YY, INCY + vstelm.w VT1, YY, 0, 2 + add.d YY, YY, INCY + vstelm.w VT1, YY, 0, 3 + add.d YY, YY, INCY + vld VX1, X, 4 * SIZE + ld.w t1, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t2, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t3, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t4, Y, 0 * SIZE + vinsgr2vr.w VX3, t1, 0 + vinsgr2vr.w VX3, t2, 1 + vinsgr2vr.w VX3, t3, 2 + vinsgr2vr.w VX3, t4, 3 + add.d Y, Y, INCY + vfmul.s VT0, VX1, VXC + vfmadd.s VT0, VX3, VXS, VT0 + vfmul.s VT1, VX1, VXS + vfmsub.s VT1, VX3, VXC, VT1 + vst VT0, X, 4 * SIZE + vstelm.w VT1, YY, 0, 0 + add.d YY, YY, INCY + vstelm.w VT1, YY, 0, 1 + add.d YY, YY, INCY + vstelm.w VT1, YY, 0, 2 + add.d YY, YY, INCY + vstelm.w VT1, YY, 0, 3 + add.d YY, YY, INCY + addi.d X, X, 8 * SIZE + addi.d I, I, -1 + blt $r0, I, .L121 + b .L997 + .align 3 + +.L122: // C!=0 S==0 + vld VX0, X, 0 * SIZE + ld.w t1, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t2, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t3, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t4, Y, 0 * SIZE + vinsgr2vr.w VX2, t1, 0 + vinsgr2vr.w VX2, t2, 1 + vinsgr2vr.w VX2, t3, 2 + vinsgr2vr.w VX2, t4, 3 + add.d Y, Y, INCY + vfmul.s VT0, VX0, VXC + vfmul.s VT1, VX2, VXC + vst VT0, X, 0 * SIZE + vstelm.w VT1, YY, 0, 0 + add.d YY, YY, INCY + vstelm.w VT1, YY, 0, 1 + add.d YY, YY, INCY + vstelm.w VT1, YY, 0, 2 + add.d YY, YY, INCY + vstelm.w VT1, YY, 0, 3 + add.d YY, YY, INCY + vld VX1, X, 4 * SIZE + ld.w t1, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t2, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t3, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t4, Y, 0 * SIZE + vinsgr2vr.w VX3, t1, 0 + vinsgr2vr.w VX3, t2, 1 + vinsgr2vr.w VX3, t3, 2 + vinsgr2vr.w VX3, t4, 3 + add.d Y, Y, INCY + vfmul.s VT0, VX1, VXC + vfmul.s VT1, VX3, VXC + vst VT0, X, 4 * SIZE + vstelm.w VT1, YY, 0, 0 + add.d YY, YY, INCY + vstelm.w VT1, YY, 0, 1 + add.d YY, YY, INCY + vstelm.w VT1, YY, 0, 2 + add.d YY, YY, INCY + vstelm.w VT1, YY, 0, 3 + add.d YY, YY, INCY + addi.d X, X, 8 * SIZE + addi.d I, I, -1 + blt $r0, I, .L122 + b .L997 + .align 3 + +.L123: // C==0 S!=0 + vld VX0, X, 0 * SIZE + ld.w t1, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t2, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t3, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t4, Y, 0 * SIZE + vinsgr2vr.w VX2, t1, 0 + vinsgr2vr.w VX2, t2, 1 + vinsgr2vr.w VX2, t3, 2 + vinsgr2vr.w VX2, t4, 3 + add.d Y, Y, INCY + vfmul.s VT0, VX2, VXS + vfmul.s VT1, VX0, VXS + vfsub.s VT1, VXZ, VT1 + vst VT0, X, 0 * SIZE + vstelm.w VT1, YY, 0, 0 + add.d YY, YY, INCY + vstelm.w VT1, YY, 0, 1 + add.d YY, YY, INCY + vstelm.w VT1, YY, 0, 2 + add.d YY, YY, INCY + vstelm.w VT1, YY, 0, 3 + add.d YY, YY, INCY + vld VX1, X, 4 * SIZE + ld.w t1, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t2, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t3, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t4, Y, 0 * SIZE + vinsgr2vr.w VX3, t1, 0 + vinsgr2vr.w VX3, t2, 1 + vinsgr2vr.w VX3, t3, 2 + vinsgr2vr.w VX3, t4, 3 + add.d Y, Y, INCY + vfmul.s VT0, VX3, VXS + vfmul.s VT1, VX1, VXS + vfsub.s VT1, VXZ, VT1 + vst VT0, X, 4 * SIZE + vstelm.w VT1, YY, 0, 0 + add.d YY, YY, INCY + vstelm.w VT1, YY, 0, 1 + add.d YY, YY, INCY + vstelm.w VT1, YY, 0, 2 + add.d YY, YY, INCY + vstelm.w VT1, YY, 0, 3 + add.d YY, YY, INCY + addi.d X, X, 8 * SIZE + addi.d I, I, -1 + blt $r0, I, .L123 + b .L997 + .align 3 + +.L124: // C==0 S==0 + vst VXZ, X, 0 * SIZE + vst VXZ, X, 4 * SIZE + vstelm.w VXZ, YY, 0, 0 + add.d YY, YY, INCY + vstelm.w VXZ, YY, 0, 1 + add.d YY, YY, INCY + vstelm.w VXZ, YY, 0, 2 + add.d YY, YY, INCY + vstelm.w VXZ, YY, 0, 3 + add.d YY, YY, INCY + vstelm.w VXZ, YY, 0, 0 + add.d YY, YY, INCY + vstelm.w VXZ, YY, 0, 1 + add.d YY, YY, INCY + vstelm.w VXZ, YY, 0, 2 + add.d YY, YY, INCY + vstelm.w VXZ, YY, 0, 3 + add.d YY, YY, INCY + addi.d I, I, -1 + blt $r0, I, .L124 + b .L997 + .align 3 + +.L21:// INCX!=1 and INCY==1 + bge $r0, I, .L997 + move XX, X + fcmp.ceq.s $fcc0, C, a1 + bcnez $fcc0, .L210 + fcmp.ceq.s $fcc0, S, a1 + bcnez $fcc0, .L212 // C!=0 S==0 + b .L211 // C!=0 S!=0 + .align 3 + +.L210: + fcmp.ceq.s $fcc0, S, a1 + bcnez $fcc0, .L214 // C==0 S==0 + b .L213 // C==0 S!=0 + .align 3 + +.L211: // C!=0 S!=0 + vld VX2, Y, 0 * SIZE + ld.w t1, X, 0 * SIZE + add.d X, X, INCX + ld.w t2, X, 0 * SIZE + add.d X, X, INCX + ld.w t3, X, 0 * SIZE + add.d X, X, INCX + ld.w t4, X, 0 * SIZE + vinsgr2vr.w VX0, t1, 0 + vinsgr2vr.w VX0, t2, 1 + vinsgr2vr.w VX0, t3, 2 + vinsgr2vr.w VX0, t4, 3 + add.d X, X, INCX + vfmul.s VT0, VXC, VX0 + vfmadd.s VT0, VX2, VXS, VT0 + vfmul.s VT1, VXS, VX0 + vfmsub.s VT1, VX2, VXC, VT1 + vstelm.w VT0, XX, 0, 0 + add.d XX, XX, INCX + vstelm.w VT0, XX, 0, 1 + add.d XX, XX, INCX + vstelm.w VT0, XX, 0, 2 + add.d XX, XX, INCX + vstelm.w VT0, XX, 0, 3 + add.d XX, XX, INCX + vst VT1, Y, 0 * SIZE + vld VX3, Y, 4 * SIZE + ld.w t1, X, 0 * SIZE + add.d X, X, INCX + ld.w t2, X, 0 * SIZE + add.d X, X, INCX + ld.w t3, X, 0 * SIZE + add.d X, X, INCX + ld.w t4, X, 0 * SIZE + vinsgr2vr.w VX1, t1, 0 + vinsgr2vr.w VX1, t2, 1 + vinsgr2vr.w VX1, t3, 2 + vinsgr2vr.w VX1, t4, 3 + add.d X, X, INCX + vfmul.s VT0, VX1, VXC + vfmadd.s VT0, VX3, VXS, VT0 + vfmul.s VT1, VX1, VXS + vfmsub.s VT1, VX3, VXC, VT1 + vstelm.w VT0, XX, 0, 0 + add.d XX, XX, INCX + vstelm.w VT0, XX, 0, 1 + add.d XX, XX, INCX + vstelm.w VT0, XX, 0, 2 + add.d XX, XX, INCX + vstelm.w VT0, XX, 0, 3 + add.d XX, XX, INCX + vst VT1, Y, 4 * SIZE + addi.d Y, Y, 8 * SIZE + addi.d I, I, -1 + blt $r0, I, .L211 + b .L997 + .align 3 + +.L212: // C!=0 S==0 + vld VX2, Y, 0 * SIZE + ld.w t1, X, 0 * SIZE + add.d X, X, INCX + ld.w t2, X, 0 * SIZE + add.d X, X, INCX + ld.w t3, X, 0 * SIZE + add.d X, X, INCX + ld.w t4, X, 0 * SIZE + vinsgr2vr.w VX0, t1, 0 + vinsgr2vr.w VX0, t2, 1 + vinsgr2vr.w VX0, t3, 2 + vinsgr2vr.w VX0, t4, 3 + add.d X, X, INCX + vfmul.s VT0, VXC, VX0 + vfmul.s VT1, VX2, VXC + vstelm.w VT0, XX, 0, 0 + add.d XX, XX, INCX + vstelm.w VT0, XX, 0, 1 + add.d XX, XX, INCX + vstelm.w VT0, XX, 0, 2 + add.d XX, XX, INCX + vstelm.w VT0, XX, 0, 3 + add.d XX, XX, INCX + vst VT1, Y, 0 * SIZE + vld VX3, Y, 4 * SIZE + ld.w t1, X, 0 * SIZE + add.d X, X, INCX + ld.w t2, X, 0 * SIZE + add.d X, X, INCX + ld.w t3, X, 0 * SIZE + add.d X, X, INCX + ld.w t4, X, 0 * SIZE + vinsgr2vr.w VX1, t1, 0 + vinsgr2vr.w VX1, t2, 1 + vinsgr2vr.w VX1, t3, 2 + vinsgr2vr.w VX1, t4, 3 + add.d X, X, INCX + vfmul.s VT0, VX1, VXC + vfmul.s VT1, VX3, VXS + vstelm.w VT0, XX, 0, 0 + add.d XX, XX, INCX + vstelm.w VT0, XX, 0, 1 + add.d XX, XX, INCX + vstelm.w VT0, XX, 0, 2 + add.d XX, XX, INCX + vstelm.w VT0, XX, 0, 3 + add.d XX, XX, INCX + vst VT1, Y, 4 * SIZE + addi.d Y, Y, 8 * SIZE + addi.d I, I, -1 + blt $r0, I, .L212 + b .L997 + .align 3 + +.L213: // C==0 S!=0 + vld VX2, Y, 0 * SIZE + ld.w t1, X, 0 * SIZE + add.d X, X, INCX + ld.w t2, X, 0 * SIZE + add.d X, X, INCX + ld.w t3, X, 0 * SIZE + add.d X, X, INCX + ld.w t4, X, 0 * SIZE + vinsgr2vr.w VX0, t1, 0 + vinsgr2vr.w VX0, t2, 1 + vinsgr2vr.w VX0, t3, 2 + vinsgr2vr.w VX0, t4, 3 + add.d X, X, INCX + vfmul.s VT0, VXS, VX2 + vfmul.s VT1, VXS, VX0 + vfsub.s VT1, VXZ, VT1 + vstelm.w VT0, XX, 0, 0 + add.d XX, XX, INCX + vstelm.w VT0, XX, 0, 1 + add.d XX, XX, INCX + vstelm.w VT0, XX, 0, 2 + add.d XX, XX, INCX + vstelm.w VT0, XX, 0, 3 + add.d XX, XX, INCX + vst VT1, Y, 0 * SIZE + vld VX3, Y, 4 * SIZE + ld.w t1, X, 0 * SIZE + add.d X, X, INCX + ld.w t2, X, 0 * SIZE + add.d X, X, INCX + ld.w t3, X, 0 * SIZE + add.d X, X, INCX + ld.w t4, X, 0 * SIZE + vinsgr2vr.w VX1, t1, 0 + vinsgr2vr.w VX1, t2, 1 + vinsgr2vr.w VX1, t3, 2 + vinsgr2vr.w VX1, t4, 3 + add.d X, X, INCX + vfmul.s VT0, VX3, VXS + vfmul.s VT1, VX1, VXS + vfsub.s VT1, VXZ, VT1 + vstelm.w VT0, XX, 0, 0 + add.d XX, XX, INCX + vstelm.w VT0, XX, 0, 1 + add.d XX, XX, INCX + vstelm.w VT0, XX, 0, 2 + add.d XX, XX, INCX + vstelm.w VT0, XX, 0, 3 + add.d XX, XX, INCX + vst VT1, Y, 4 * SIZE + addi.d Y, Y, 8 * SIZE + addi.d I, I, -1 + blt $r0, I, .L213 + b .L997 + .align 3 + +.L214: // C==0 S==0 + vstelm.w VXZ, XX, 0, 0 + add.d XX, XX, INCX + vstelm.w VXZ, XX, 0, 1 + add.d XX, XX, INCX + vstelm.w VXZ, XX, 0, 2 + add.d XX, XX, INCX + vstelm.w VXZ, XX, 0, 3 + add.d XX, XX, INCX + vst VT1, Y, 0 * SIZE + vstelm.w VXZ, XX, 0, 0 + add.d XX, XX, INCX + vstelm.w VXZ, XX, 0, 1 + add.d XX, XX, INCX + vstelm.w VXZ, XX, 0, 2 + add.d XX, XX, INCX + vstelm.w VXZ, XX, 0, 3 + add.d XX, XX, INCX + vst VT1, Y, 4 * SIZE + addi.d Y, Y, 8 * SIZE + addi.d I, I, -1 + blt $r0, I, .L211 + b .L997 + .align 3 + +.L22: + bge $r0, I, .L997 + move YY, Y + move XX, X + fcmp.ceq.s $fcc0, C, a1 + bcnez $fcc0, .L220 + fcmp.ceq.s $fcc0, S, a1 + bcnez $fcc0, .L222 // C!=0 S==0 + b .L221 // C!=0 S!=0 + .align 3 + +.L220: + fcmp.ceq.s $fcc0, S, a1 + bcnez $fcc0, .L224 // C==0 S==0 + b .L223 // C==0 S!=0 + .align 3 + +.L221: // C!=0 S!=0 + ld.w t1, X, 0 * SIZE + add.d X, X, INCX + ld.w t2, X, 0 * SIZE + add.d X, X, INCX + ld.w t3, X, 0 * SIZE + add.d X, X, INCX + ld.w t4, X, 0 * SIZE + add.d X, X, INCX + vinsgr2vr.w VX0, t1, 0 + vinsgr2vr.w VX0, t2, 1 + vinsgr2vr.w VX0, t3, 2 + vinsgr2vr.w VX0, t4, 3 + ld.w t1, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t2, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t3, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t4, Y, 0 * SIZE + vinsgr2vr.w VX2, t1, 0 + vinsgr2vr.w VX2, t2, 1 + vinsgr2vr.w VX2, t3, 2 + vinsgr2vr.w VX2, t4, 3 + add.d Y, Y, INCY + vfmul.s VT0, VX0, VXC + vfmadd.s VT0, VX2, VXS, VT0 + vfmul.s VT1, VX0, VXS + vfmsub.s VT1, VX2, VXC, VT1 + vstelm.w VT0, XX, 0, 0 + add.d XX, XX, INCX + vstelm.w VT0, XX, 0, 1 + add.d XX, XX, INCX + vstelm.w VT0, XX, 0, 2 + add.d XX, XX, INCX + vstelm.w VT0, XX, 0, 3 + add.d XX, XX, INCX + vstelm.w VT1, YY, 0, 0 + add.d YY, YY, INCY + vstelm.w VT1, YY, 0, 1 + add.d YY, YY, INCY + vstelm.w VT1, YY, 0, 2 + add.d YY, YY, INCY + vstelm.w VT1, YY, 0, 3 + add.d YY, YY, INCY + ld.w t1, X, 0 * SIZE + add.d X, X, INCX + ld.w t2, X, 0 * SIZE + add.d X, X, INCX + ld.w t3, X, 0 * SIZE + add.d X, X, INCX + ld.w t4, X, 0 * SIZE + vinsgr2vr.w VX1, t1, 0 + vinsgr2vr.w VX1, t2, 1 + vinsgr2vr.w VX1, t3, 2 + vinsgr2vr.w VX1, t4, 3 + add.d X, X, INCX + ld.w t1, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t2, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t3, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t4, Y, 0 * SIZE + vinsgr2vr.w VX3, t1, 0 + vinsgr2vr.w VX3, t2, 1 + vinsgr2vr.w VX3, t3, 2 + vinsgr2vr.w VX3, t4, 3 + add.d Y, Y, INCY + vfmul.s VT0, VX1, VXC + vfmadd.s VT0, VX3, VXS, VT0 + vfmul.s VT1, VX0, VXS + vfmsub.s VT1, VX3, VXC, VT1 + vstelm.w VT0, XX, 0, 0 + add.d XX, XX, INCX + vstelm.w VT0, XX, 0, 1 + add.d XX, XX, INCX + vstelm.w VT0, XX, 0, 2 + add.d XX, XX, INCX + vstelm.w VT0, XX, 0, 3 + add.d XX, XX, INCX + vstelm.w VT1, YY, 0, 0 + add.d YY, YY, INCY + vstelm.w VT1, YY, 0, 1 + add.d YY, YY, INCY + vstelm.w VT1, YY, 0, 2 + add.d YY, YY, INCY + vstelm.w VT1, YY, 0, 3 + add.d YY, YY, INCY + addi.d I, I, -1 + blt $r0, I, .L221 + b .L997 + .align 3 + +.L222: // C!=0 S==0 + ld.w t1, X, 0 * SIZE + add.d X, X, INCX + ld.w t2, X, 0 * SIZE + add.d X, X, INCX + ld.w t3, X, 0 * SIZE + add.d X, X, INCX + ld.w t4, X, 0 * SIZE + add.d X, X, INCX + vinsgr2vr.w VX0, t1, 0 + vinsgr2vr.w VX0, t2, 1 + vinsgr2vr.w VX0, t3, 2 + vinsgr2vr.w VX0, t4, 3 + ld.w t1, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t2, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t3, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t4, Y, 0 * SIZE + vinsgr2vr.w VX2, t1, 0 + vinsgr2vr.w VX2, t2, 1 + vinsgr2vr.w VX2, t3, 2 + vinsgr2vr.w VX2, t4, 3 + add.d Y, Y, INCY + vfmul.s VT0, VX0, VXC + vfmul.s VT1, VX2, VXC + vstelm.w VT0, XX, 0, 0 + add.d XX, XX, INCX + vstelm.w VT0, XX, 0, 1 + add.d XX, XX, INCX + vstelm.w VT0, XX, 0, 2 + add.d XX, XX, INCX + vstelm.w VT0, XX, 0, 3 + add.d XX, XX, INCX + vstelm.w VT1, YY, 0, 0 + add.d YY, YY, INCY + vstelm.w VT1, YY, 0, 1 + add.d YY, YY, INCY + vstelm.w VT1, YY, 0, 2 + add.d YY, YY, INCY + vstelm.w VT1, YY, 0, 3 + add.d YY, YY, INCY + ld.w t1, X, 0 * SIZE + add.d X, X, INCX + ld.w t2, X, 0 * SIZE + add.d X, X, INCX + ld.w t3, X, 0 * SIZE + add.d X, X, INCX + ld.w t4, X, 0 * SIZE + add.d X, X, INCX + vinsgr2vr.w VX1, t1, 0 + vinsgr2vr.w VX1, t2, 1 + vinsgr2vr.w VX1, t3, 2 + vinsgr2vr.w VX1, t4, 3 + ld.w t1, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t2, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t3, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t4, Y, 0 * SIZE + vinsgr2vr.w VX3, t1, 0 + vinsgr2vr.w VX3, t2, 1 + vinsgr2vr.w VX3, t3, 2 + vinsgr2vr.w VX3, t4, 3 + add.d Y, Y, INCY + vfmul.s VT0, VX1, VXC + vfmul.s VT1, VX3, VXC + vstelm.w VT0, XX, 0, 0 + add.d XX, XX, INCX + vstelm.w VT0, XX, 0, 1 + add.d XX, XX, INCX + vstelm.w VT0, XX, 0, 2 + add.d XX, XX, INCX + vstelm.w VT0, XX, 0, 3 + add.d XX, XX, INCX + vstelm.w VT1, YY, 0, 0 + add.d YY, YY, INCY + vstelm.w VT1, YY, 0, 1 + add.d YY, YY, INCY + vstelm.w VT1, YY, 0, 2 + add.d YY, YY, INCY + vstelm.w VT1, YY, 0, 3 + add.d YY, YY, INCY + addi.d I, I, -1 + blt $r0, I, .L222 + b .L997 + .align 3 + +.L223: // C==0 S!=0 + ld.w t1, X, 0 * SIZE + add.d X, X, INCX + ld.w t2, X, 0 * SIZE + add.d X, X, INCX + ld.w t3, X, 0 * SIZE + add.d X, X, INCX + ld.w t4, X, 0 * SIZE + add.d X, X, INCX + vinsgr2vr.w VX0, t1, 0 + vinsgr2vr.w VX0, t2, 1 + vinsgr2vr.w VX0, t3, 2 + vinsgr2vr.w VX0, t4, 3 + ld.w t1, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t2, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t3, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t4, Y, 0 * SIZE + vinsgr2vr.w VX2, t1, 0 + vinsgr2vr.w VX2, t2, 1 + vinsgr2vr.w VX2, t3, 2 + vinsgr2vr.w VX2, t4, 3 + add.d Y, Y, INCY + vfmul.s VT0, VX2, VXS + vfmul.s VT1, VX0, VXS + vfsub.s VT1, VXZ, VT1 + vstelm.w VT0, XX, 0, 0 + add.d XX, XX, INCX + vstelm.w VT0, XX, 0, 1 + add.d XX, XX, INCX + vstelm.w VT0, XX, 0, 2 + add.d XX, XX, INCX + vstelm.w VT0, XX, 0, 3 + add.d XX, XX, INCX + vstelm.w VT1, YY, 0, 0 + add.d YY, YY, INCY + vstelm.w VT1, YY, 0, 1 + add.d YY, YY, INCY + vstelm.w VT1, YY, 0, 2 + add.d YY, YY, INCY + vstelm.w VT1, YY, 0, 3 + add.d YY, YY, INCY + ld.w t1, X, 0 * SIZE + add.d X, X, INCX + ld.w t2, X, 0 * SIZE + add.d X, X, INCX + ld.w t3, X, 0 * SIZE + add.d X, X, INCX + ld.w t4, X, 0 * SIZE + add.d X, X, INCX + vinsgr2vr.w VX1, t1, 0 + vinsgr2vr.w VX1, t2, 1 + vinsgr2vr.w VX1, t3, 2 + vinsgr2vr.w VX1, t4, 3 + ld.w t1, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t2, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t3, Y, 0 * SIZE + add.d Y, Y, INCY + ld.w t4, Y, 0 * SIZE + vinsgr2vr.w VX3, t1, 0 + vinsgr2vr.w VX3, t2, 1 + vinsgr2vr.w VX3, t3, 2 + vinsgr2vr.w VX3, t4, 3 + add.d Y, Y, INCY + vfmul.s VT0, VX3, VXS + vfmul.s VT1, VX0, VXS + vfsub.s VT1, VXZ, VT1 + vstelm.w VT0, XX, 0, 0 + add.d XX, XX, INCX + vstelm.w VT0, XX, 0, 1 + add.d XX, XX, INCX + vstelm.w VT0, XX, 0, 2 + add.d XX, XX, INCX + vstelm.w VT0, XX, 0, 3 + add.d XX, XX, INCX + vstelm.w VT1, YY, 0, 0 + add.d YY, YY, INCY + vstelm.w VT1, YY, 0, 1 + add.d YY, YY, INCY + vstelm.w VT1, YY, 0, 2 + add.d YY, YY, INCY + vstelm.w VT1, YY, 0, 3 + add.d YY, YY, INCY + addi.d I, I, -1 + blt $r0, I, .L223 + b .L997 + .align 3 + +.L224: // C==0 S==0 + vstelm.w VXZ, XX, 0, 0 + add.d XX, XX, INCX + vstelm.w VXZ, XX, 0, 1 + add.d XX, XX, INCX + vstelm.w VXZ, XX, 0, 2 + add.d XX, XX, INCX + vstelm.w VXZ, XX, 0, 3 + add.d XX, XX, INCX + vstelm.w VXZ, YY, 0, 0 + add.d YY, YY, INCY + vstelm.w VXZ, YY, 0, 1 + add.d YY, YY, INCY + vstelm.w VXZ, YY, 0, 2 + add.d YY, YY, INCY + vstelm.w VXZ, YY, 0, 3 + add.d YY, YY, INCY + vstelm.w VXZ, XX, 0, 0 + add.d XX, XX, INCX + vstelm.w VXZ, XX, 0, 1 + add.d XX, XX, INCX + vstelm.w VXZ, XX, 0, 2 + add.d XX, XX, INCX + vstelm.w VXZ, XX, 0, 3 + add.d XX, XX, INCX + vstelm.w VXZ, YY, 0, 0 + add.d YY, YY, INCY + vstelm.w VXZ, YY, 0, 1 + add.d YY, YY, INCY + vstelm.w VXZ, YY, 0, 2 + add.d YY, YY, INCY + vstelm.w VXZ, YY, 0, 3 + add.d YY, YY, INCY + addi.d I, I, -1 + blt $r0, I, .L224 + b .L997 + .align 3 + +.L997: + andi I, N, 7 + bge $r0, I, .L999 + .align 3 + +.L998: + fld.s $f12, X, 0 * SIZE + fld.s $f13, Y, 0 * SIZE + fmul.s $f10, $f12, C + fmadd.s $f10, $f13, S, $f10 + fst.s $f10, X, 0 * SIZE + addi.d I, I, -1 + fmul.s $f20, $f12, S + fmsub.s $f20, $f13, C, $f20 + fst.s $f20, Y, 0 * SIZE + add.d X, X, INCX + add.d Y, Y, INCY + blt $r0, I, .L998 + .align 3 + +.L999: + move $r4, $r12 + jirl $r0, $r1, 0x0 + .align 3 + + EPILOGUE \ No newline at end of file From d32f38fb37c94afae20a662182fe7178c005a673 Mon Sep 17 00:00:00 2001 From: yancheng Date: Thu, 7 Dec 2023 13:15:55 +0800 Subject: [PATCH 57/60] loongarch64: Add optimizations for nrm2. --- kernel/loongarch64/KERNEL.LOONGSON2K1000 | 3 + kernel/loongarch64/KERNEL.LOONGSON3R5 | 3 + kernel/loongarch64/dnrm2_lasx.S | 233 ++++++++++++++++++++++ kernel/loongarch64/dnrm2_lsx.S | 242 +++++++++++++++++++++++ kernel/loongarch64/snrm2_lasx.S | 143 ++++++++++++++ kernel/loongarch64/snrm2_lsx.S | 156 +++++++++++++++ 6 files changed, 780 insertions(+) create mode 100644 kernel/loongarch64/dnrm2_lasx.S create mode 100644 kernel/loongarch64/dnrm2_lsx.S create mode 100644 kernel/loongarch64/snrm2_lasx.S create mode 100644 kernel/loongarch64/snrm2_lsx.S diff --git a/kernel/loongarch64/KERNEL.LOONGSON2K1000 b/kernel/loongarch64/KERNEL.LOONGSON2K1000 index 026ea0d77..1e4fa7a9d 100644 --- a/kernel/loongarch64/KERNEL.LOONGSON2K1000 +++ b/kernel/loongarch64/KERNEL.LOONGSON2K1000 @@ -52,4 +52,7 @@ DASUMKERNEL = dasum_lsx.S SROTKERNEL = srot_lsx.S DROTKERNEL = drot_lsx.S +SNRM2KERNEL = snrm2_lsx.S +DNRM2KERNEL = dnrm2_lsx.S + endif diff --git a/kernel/loongarch64/KERNEL.LOONGSON3R5 b/kernel/loongarch64/KERNEL.LOONGSON3R5 index 4905a50a9..f00abcb32 100644 --- a/kernel/loongarch64/KERNEL.LOONGSON3R5 +++ b/kernel/loongarch64/KERNEL.LOONGSON3R5 @@ -52,6 +52,9 @@ DASUMKERNEL = dasum_lasx.S SROTKERNEL = srot_lasx.S DROTKERNEL = drot_lasx.S +SNRM2KERNEL = snrm2_lasx.S +DNRM2KERNEL = dnrm2_lasx.S + DGEMMKERNEL = dgemm_kernel_16x4.S DGEMMINCOPY = dgemm_ncopy_16.S DGEMMITCOPY = dgemm_tcopy_16.S diff --git a/kernel/loongarch64/dnrm2_lasx.S b/kernel/loongarch64/dnrm2_lasx.S new file mode 100644 index 000000000..2a9c3cf7b --- /dev/null +++ b/kernel/loongarch64/dnrm2_lasx.S @@ -0,0 +1,233 @@ +#define ASSEMBLER + +#include "common.h" + +#define N $r4 +#define X $r5 +#define INCX $r6 +#define XX $r19 +#define I $r17 +#define TEMP $r18 +#define t1 $r12 +#define t2 $r13 +#define t3 $r14 +#define t4 $r15 +#define VX0 $xr15 +#define VX1 $xr16 +#define VM0 $xr17 +#define VM1 $xr18 +#define VM2 $xr13 +#define VM3 $xr14 +#define res1 $xr19 +#define res2 $xr20 +#define VALPHA $xr21 +#define INF $f23 +#define a1 $f22 +#define max $f17 +#define ALPHA $f12 + + PROLOGUE + +#ifdef F_INTERFACE + LDINT N, 0(N) + LDINT INCX, 0(INCX) +#endif + + xvxor.v res1, res1, res1 + xvxor.v res2, res2, res2 + bge $r0, N, .L999 + beq $r0, INCX, .L999 + move XX, X + // Init INF + addi.d TEMP, $r0, 0x7FF + slli.d TEMP, TEMP, 52 + MTC INF, TEMP + li.d TEMP, SIZE + slli.d INCX, INCX, BASE_SHIFT + srai.d I, N, 3 + bne INCX, TEMP, .L20 + xvld VM0, X, 0 + bge $r0, I, .L97 + .align 3 + +.L10: + xvld VX0, X, 0 * SIZE + xvld VX1, X, 4 * SIZE + xvfmaxa.d VM1, VX1, VX0 + xvfmaxa.d VM0, VM0, VM1 + addi.d I, I, -1 + addi.d X, X, 8 * SIZE + blt $r0, I, .L10 + b .L96 + .align 3 + +.L20: // INCX!=1 + move TEMP, X // initialize the maxa value + ld.d t1, TEMP, 0 * SIZE + add.d TEMP, TEMP, INCX + xvinsgr2vr.d VM0, t1, 0 + srai.d I, N, 3 + bge $r0, I, .L97 + ld.d t2, TEMP, 0 * SIZE + add.d TEMP, TEMP, INCX + xvinsgr2vr.d VM0, t2, 1 + .align 3 + +.L21: + ld.d t1, X, 0 * SIZE + add.d X, X, INCX + xvinsgr2vr.d VX0, t1, 0 + ld.d t2, X, 0 * SIZE + add.d X, X, INCX + xvinsgr2vr.d VX0, t2, 1 + ld.d t3, X, 0 * SIZE + add.d X, X, INCX + xvinsgr2vr.d VX0, t3, 2 + ld.d t4, X, 0 * SIZE + add.d X, X, INCX + xvinsgr2vr.d VX0, t4, 3 + ld.d t1, X, 0 * SIZE + add.d X, X, INCX + xvinsgr2vr.d VX1, t1, 0 + ld.d t2, X, 0 * SIZE + add.d X, X, INCX + xvinsgr2vr.d VX1, t2, 1 + ld.d t3, X, 0 * SIZE + add.d X, X, INCX + xvinsgr2vr.d VX1, t3, 2 + ld.d t4, X, 0 * SIZE + add.d X, X, INCX + xvinsgr2vr.d VX1, t4, 3 + xvfmaxa.d VM1, VX0, VX1 + xvfmaxa.d VM0, VM0, VM1 + addi.d I, I, -1 + blt $r0, I, .L21 + b .L96 + .align 3 + +.L96: + xvpickve.d VX0, VM0, 1 + xvpickve.d VX1, VM0, 2 + xvpickve.d VM3, VM0, 3 + xvfmaxa.d VM1, VX0, VX1 + xvfmaxa.d VM2, VM3, VM0 + xvfmaxa.d VM0, VM1, VM2 + .align 3 + +.L97: + andi I, N, 7 + bge $r0, I, .L99 + .align 3 + +.L98: + xvld VX1, X, 0 + xvfmaxa.d VM0, VM0, VX1 + addi.d I, I, -1 + add.d X, X, INCX + blt $r0, I, .L98 + .align 3 + +.L99: + fabs.d max, max + lu12i.w TEMP, 0x3f800 // 1 + movgr2fr.d a1, $r0 + movgr2fr.w ALPHA, TEMP + CMPEQ $fcc0, max, a1 + fcvt.d.s ALPHA, ALPHA + bcnez $fcc0, .L999 + fdiv.d ALPHA, ALPHA, max + CMPEQ $fcc0, INF, ALPHA + bcnez $fcc0, .L999 + movfr2gr.d TEMP, ALPHA + xvreplgr2vr.d VALPHA, TEMP + +.L100: + li.d TEMP, SIZE + bne INCX, TEMP, .L120 + srai.d I, N, 3 + bge $r0, I, .L997 + .align 3 + +.L110: + xvld VX0, XX, 0 * SIZE + xvld VX1, XX, 4 * SIZE + xvfmul.d VM0, VX0, VALPHA + xvfmul.d VM1, VX1, VALPHA + xvfmadd.d res1, VM0, VM0, res1 + xvfmadd.d res2, VM1, VM1, res2 + addi.d XX, XX, 8 * SIZE + addi.d I, I, -1 + blt $r0, I, .L110 + b .L996 + .align 3 + +.L120: + srai.d I, N, 3 + bge $r0, I, .L997 + +.L121: + ld.d t1, XX, 0 * SIZE + add.d XX, XX, INCX + ld.d t2, XX, 0 * SIZE + add.d XX, XX, INCX + ld.d t3, XX, 0 * SIZE + add.d XX, XX, INCX + ld.d t4, XX, 0 * SIZE + add.d XX, XX, INCX + xvinsgr2vr.d VX0, t1, 0 + xvinsgr2vr.d VX0, t2, 1 + xvinsgr2vr.d VX0, t3, 2 + xvinsgr2vr.d VX0, t4, 3 + ld.d t1, XX, 0 * SIZE + add.d XX, XX, INCX + ld.d t2, XX, 0 * SIZE + add.d XX, XX, INCX + ld.d t3, XX, 0 * SIZE + add.d XX, XX, INCX + ld.d t4, XX, 0 * SIZE + add.d XX, XX, INCX + xvinsgr2vr.d VX0, t1, 0 + xvinsgr2vr.d VX0, t2, 1 + xvinsgr2vr.d VX1, t3, 2 + xvinsgr2vr.d VX1, t4, 3 + xvfmul.d VM0, VX0, VALPHA + xvfmul.d VM1, VX1, VALPHA + xvfmadd.d res1, VM0, VM0, res1 + xvfmadd.d res2, VM1, VM1, res2 + addi.d I, I, -1 + blt $r0, I, .L121 + b .L996 + .align 3 + +.L996: + xvfadd.d res1, res1, res2 + xvpickve.d VX0, res1, 1 + xvpickve.d VX1, res1, 2 + xvpickve.d VM0, res1, 3 + xvfadd.d res1, VX0, res1 + xvfadd.d VX1, VX1, VM0 + xvfadd.d res1, VX1, res1 + .align 3 + +.L997: + andi I, N, 7 + bge $r0, I, .L999 + .align 3 + +.L998: + fld.d $f15, XX, 0 * SIZE + addi.d I, I, -1 + fmul.d $f15, $f15, ALPHA + fmadd.d $f19, $f15, $f15, $f19 + add.d XX, XX , INCX + blt $r0, I, .L998 + fsqrt.d $f19, $f19 + fmul.d $f0, max, $f19 + jirl $r0, $r1, 0x0 + .align 3 + +.L999: + fmov.d $f0, $f19 + jirl $r0, $r1, 0x0 + + EPILOGUE diff --git a/kernel/loongarch64/dnrm2_lsx.S b/kernel/loongarch64/dnrm2_lsx.S new file mode 100644 index 000000000..e4615e18d --- /dev/null +++ b/kernel/loongarch64/dnrm2_lsx.S @@ -0,0 +1,242 @@ +#define ASSEMBLER + +#include "common.h" + +#define N $r4 +#define X $r5 +#define INCX $r6 +#define XX $r19 +#define I $r17 +#define TEMP $r18 +#define t1 $r12 +#define t2 $r13 +#define t3 $r14 +#define t4 $r15 +#define VX0 $vr15 +#define VX1 $vr16 +#define VM0 $vr17 +#define VM1 $vr18 +#define VM2 $vr13 +#define VM3 $vr14 +#define res1 $vr19 +#define res2 $vr20 +#define VALPHA $vr21 +#define INF $f23 +#define a1 $f22 +#define max $f17 +#define ALPHA $f12 + + PROLOGUE + +#ifdef F_INTERFACE + LDINT N, 0(N) + LDINT INCX, 0(INCX) +#endif + + vxor.v res1, res1, res1 + vxor.v res2, res2, res2 + bge $r0, N, .L999 + beq $r0, INCX, .L999 + move XX, X + // Init INF + addi.d TEMP, $r0, 0x7FF + slli.d TEMP, TEMP, 52 + MTC INF, TEMP + li.d TEMP, SIZE + slli.d INCX, INCX, BASE_SHIFT + srai.d I, N, 3 + bne INCX, TEMP, .L20 + vld VM0, X, 0 + bge $r0, I, .L97 + .align 3 + +.L10: + vld VX0, X, 0 * SIZE + vld VX1, X, 2 * SIZE + vfmaxa.d VM1, VX1, VX0 + vld VX0, X, 4 * SIZE + vld VX1, X, 6 * SIZE + vfmaxa.d VM2, VX1, VX0 + vfmaxa.d VM3, VM1, VM2 + vfmaxa.d VM0, VM0, VM3 + addi.d I, I, -1 + addi.d X, X, 8 * SIZE + blt $r0, I, .L10 + b .L96 + .align 3 + +.L20: // INCX!=1 + move TEMP, X // initialize the maxa value + ld.d t1, TEMP, 0 * SIZE + add.d TEMP, TEMP, INCX + vinsgr2vr.d VM0, t1, 0 + srai.d I, N, 3 + bge $r0, I, .L97 + ld.d t2, TEMP, 0 * SIZE + add.d TEMP, TEMP, INCX + vinsgr2vr.d VM0, t2, 1 + .align 3 + +.L21: + ld.d t1, X, 0 * SIZE + add.d X, X, INCX + vinsgr2vr.d VX0, t1, 0 + ld.d t2, X, 0 * SIZE + add.d X, X, INCX + vinsgr2vr.d VX0, t2, 1 + ld.d t3, X, 0 * SIZE + add.d X, X, INCX + vinsgr2vr.d VX1, t3, 0 + ld.d t4, X, 0 * SIZE + add.d X, X, INCX + vinsgr2vr.d VX1, t4, 1 + vfmaxa.d VM1, VX0, VX1 + ld.d t1, X, 0 * SIZE + add.d X, X, INCX + vinsgr2vr.d VX0, t1, 0 + ld.d t2, X, 0 * SIZE + add.d X, X, INCX + vinsgr2vr.d VX0, t2, 1 + ld.d t3, X, 0 * SIZE + add.d X, X, INCX + vinsgr2vr.d VX1, t3, 0 + ld.d t4, X, 0 * SIZE + add.d X, X, INCX + vinsgr2vr.d VX1, t4, 1 + vfmaxa.d VM2, VX0, VX1 + vfmaxa.d VM3, VM1, VM2 + vfmaxa.d VM0, VM0, VM3 + addi.d I, I, -1 + blt $r0, I, .L21 + b .L96 + .align 3 + +.L96: + vreplvei.d VX0, VM0, 0 + vreplvei.d VX1, VM0, 1 + vfmaxa.d VM0, VX0, VX1 + .align 3 + +.L97: + andi I, N, 7 + bge $r0, I, .L99 + .align 3 + +.L98: + vld VX1, X, 0 + vfmaxa.d VM0, VM0, VX1 + addi.d I, I, -1 + add.d X, X, INCX + blt $r0, I, .L98 + .align 3 + +.L99: + fabs.d max, max + lu12i.w TEMP, 0x3f800 // 1 + movgr2fr.d a1, $r0 + movgr2fr.w ALPHA, TEMP + CMPEQ $fcc0, max, a1 + fcvt.d.s ALPHA, ALPHA + bcnez $fcc0, .L999 + fdiv.d ALPHA, ALPHA, max + CMPEQ $fcc0, INF, ALPHA + bcnez $fcc0, .L999 + movfr2gr.d TEMP, ALPHA + vreplgr2vr.d VALPHA, TEMP + +.L100: + li.d TEMP, SIZE + bne INCX, TEMP, .L120 + srai.d I, N, 3 + bge $r0, I, .L997 + .align 3 + +.L110: + vld VX0, XX, 0 * SIZE + vld VX1, XX, 2 * SIZE + vfmul.d VM0, VX0, VALPHA + vfmul.d VM1, VX1, VALPHA + vfmadd.d res1, VM0, VM0, res1 + vfmadd.d res2, VM1, VM1, res2 + vld VX0, XX, 4 * SIZE + vld VX1, XX, 6 * SIZE + vfmul.d VM0, VX0, VALPHA + vfmul.d VM1, VX1, VALPHA + vfmadd.d res1, VM0, VM0, res1 + vfmadd.d res2, VM1, VM1, res2 + addi.d XX, XX, 8 * SIZE + addi.d I, I, -1 + blt $r0, I, .L110 + b .L996 + .align 3 + +.L120: + srai.d I, N, 3 + bge $r0, I, .L997 + +.L121: + ld.d t1, XX, 0 * SIZE + add.d XX, XX, INCX + ld.d t2, XX, 0 * SIZE + add.d XX, XX, INCX + ld.d t3, XX, 0 * SIZE + add.d XX, XX, INCX + ld.d t4, XX, 0 * SIZE + add.d XX, XX, INCX + vinsgr2vr.d VX0, t1, 0 + vinsgr2vr.d VX0, t2, 1 + vinsgr2vr.d VX1, t3, 0 + vinsgr2vr.d VX1, t4, 1 + vfmul.d VM0, VX0, VALPHA + ld.d t1, XX, 0 * SIZE + add.d XX, XX, INCX + vfmul.d VM1, VX1, VALPHA + ld.d t2, XX, 0 * SIZE + add.d XX, XX, INCX + vfmadd.d res1, VM0, VM0, res1 + vfmadd.d res2, VM1, VM1, res2 + ld.d t3, XX, 0 * SIZE + add.d XX, XX, INCX + ld.d t4, XX, 0 * SIZE + add.d XX, XX, INCX + vinsgr2vr.d VX0, t1, 0 + vinsgr2vr.d VX0, t2, 1 + vinsgr2vr.d VX1, t3, 0 + vinsgr2vr.d VX1, t4, 1 + vfmul.d VM0, VX0, VALPHA + vfmul.d VM1, VX1, VALPHA + vfmadd.d res1, VM0, VM0, res1 + vfmadd.d res2, VM1, VM1, res2 + addi.d I, I, -1 + blt $r0, I, .L121 + b .L996 + .align 3 + +.L996: + vfadd.d res1, res1, res2 + vreplvei.d VX1, res1, 1 + vfadd.d res1, VX1, res1 + .align 3 + +.L997: + andi I, N, 7 + bge $r0, I, .L999 + .align 3 + +.L998: + fld.d $f15, XX, 0 * SIZE + addi.d I, I, -1 + fmul.d $f15, $f15, ALPHA + fmadd.d $f19, $f15, $f15, $f19 + add.d XX, XX , INCX + blt $r0, I, .L998 + fsqrt.d $f19, $f19 + fmul.d $f0, max, $f19 + jirl $r0, $r1, 0x0 + .align 3 + +.L999: + fmov.d $f0, $f19 + jirl $r0, $r1, 0x0 + + EPILOGUE diff --git a/kernel/loongarch64/snrm2_lasx.S b/kernel/loongarch64/snrm2_lasx.S new file mode 100644 index 000000000..274908c14 --- /dev/null +++ b/kernel/loongarch64/snrm2_lasx.S @@ -0,0 +1,143 @@ +#define ASSEMBLER + +#include "common.h" + +#define N $r4 +#define X $r5 +#define INCX $r6 +#define I $r17 +#define TEMP $r18 +#define t1 $r12 +#define t2 $r13 +#define t3 $r14 +#define t4 $r15 +#define VX0 $xr15 +#define VX1 $xr16 +#define VX2 $xr17 +#define VX3 $xr18 +#define res1 $xr19 +#define res2 $xr20 + + PROLOGUE + +#ifdef F_INTERFACE + LDINT N, 0(N) + LDINT INCX, 0(INCX) +#endif + + xvxor.v res1, res1, res1 + xvxor.v res2, res2, res2 + bge $r0, N, .L999 + beq $r0, INCX, .L999 + li.d TEMP, SIZE + slli.d INCX, INCX, BASE_SHIFT + srai.d I, N, 3 + bne INCX, TEMP, .L20 + bge $r0, I, .L997 + .align 3 + +.L10: + xvld VX0, X, 0 * SIZE + xvld VX1, X, 0 * SIZE + xvfcvtl.d.s VX0, VX0 + xvfcvth.d.s VX1, VX1 + xvfmadd.d res1, VX0, VX0, res1 + xvfmadd.d res2, VX1, VX1, res2 + addi.d I, I, -1 + addi.d X, X, 8 * SIZE + blt $r0, I, .L10 + .align 3 + b .L996 + +.L20: + bge $r0, I, .L997 + .align 3 + +.L21: + ld.w t1, X, 0 * SIZE + add.d X, X, INCX + ld.w t2, X, 0 * SIZE + add.d X, X, INCX + ld.w t3, X, 0 * SIZE + add.d X, X, INCX + ld.w t4, X, 0 * SIZE + add.d X, X, INCX + xvinsgr2vr.w VX0, t1, 0 + xvinsgr2vr.w VX0, t2, 1 + xvinsgr2vr.w VX0, t3, 2 + xvinsgr2vr.w VX0, t4, 3 + ld.w t1, X, 0 * SIZE + add.d X, X, INCX + ld.w t2, X, 0 * SIZE + add.d X, X, INCX + ld.w t3, X, 0 * SIZE + add.d X, X, INCX + ld.w t4, X, 0 * SIZE + add.d X, X, INCX + xvinsgr2vr.w VX0, t1, 4 + xvinsgr2vr.w VX0, t2, 5 + xvinsgr2vr.w VX0, t3, 6 + xvinsgr2vr.w VX0, t4, 7 + ld.w t1, X, 0 * SIZE + add.d X, X, INCX + ld.w t2, X, 0 * SIZE + add.d X, X, INCX + ld.w t3, X, 0 * SIZE + add.d X, X, INCX + ld.w t4, X, 0 * SIZE + add.d X, X, INCX + xvinsgr2vr.w VX1, t1, 0 + xvinsgr2vr.w VX1, t2, 1 + xvinsgr2vr.w VX1, t3, 2 + xvinsgr2vr.w VX1, t4, 3 + ld.w t1, X, 0 * SIZE + add.d X, X, INCX + ld.w t2, X, 0 * SIZE + add.d X, X, INCX + ld.w t3, X, 0 * SIZE + add.d X, X, INCX + ld.w t4, X, 0 * SIZE + add.d X, X, INCX + xvinsgr2vr.w VX1, t1, 4 + xvinsgr2vr.w VX1, t2, 5 + xvinsgr2vr.w VX1, t3, 6 + xvinsgr2vr.w VX1, t4, 7 + xvfcvtl.d.s VX0, VX0 + xvfcvth.d.s VX1, VX1 + xvfmadd.d res1, VX0, VX0, res1 + xvfmadd.d res2, VX1, VX1, res2 + addi.d I, I, -1 + blt $r0, I, .L21 + b .L996 + +.L996: + xvfadd.d res1, res1, res2 + xvpickve.w VX1, res1, 1 + xvpickve.w VX2, res1, 2 + xvpickve.w VX3, res1, 3 + xvfadd.s res1, VX1, res1 + xvfadd.s res1, VX2, res1 + xvfadd.s res1, VX3, res1 + .align 3 + +.L997: + andi I, N, 7 + bge $r0, I, .L999 + .align 3 + +.L998: + fld.s $f15, X, 0 * SIZE + addi.d I, I, -1 + fcvt.d.s $f15, $f15 + fmadd.d $f19, $f15, $f15, $f19 + add.d X, X, INCX + blt $r0, I, .L998 + .align 3 + +.L999: + fsqrt.d $f19, $f19 + move $r4, $r17 + fcvt.s.d $f0, $f19 + jirl $r0, $r1, 0x0 + + EPILOGUE diff --git a/kernel/loongarch64/snrm2_lsx.S b/kernel/loongarch64/snrm2_lsx.S new file mode 100644 index 000000000..17d017900 --- /dev/null +++ b/kernel/loongarch64/snrm2_lsx.S @@ -0,0 +1,156 @@ +#define ASSEMBLER + +#include "common.h" + +#define N $r4 +#define X $r5 +#define INCX $r6 +#define I $r17 +#define TEMP $r18 +#define t1 $r12 +#define t2 $r13 +#define t3 $r14 +#define t4 $r15 +#define VX0 $vr15 +#define VX1 $vr16 +#define VX2 $vr17 +#define VX3 $vr18 +#define res1 $vr19 +#define res2 $vr20 + + PROLOGUE + +#ifdef F_INTERFACE + LDINT N, 0(N) + LDINT INCX, 0(INCX) +#endif + + vxor.v res1, res1, res1 + vxor.v res2, res2, res2 + bge $r0, N, .L999 + beq $r0, INCX, .L999 + li.d TEMP, SIZE + slli.d INCX, INCX, BASE_SHIFT + srai.d I, N, 3 + bne INCX, TEMP, .L20 + bge $r0, I, .L997 + .align 3 + +.L10: + vld VX0, X, 0 * SIZE + vld VX1, X, 0 * SIZE + vfcvtl.d.s VX0, VX0 + vfcvth.d.s VX1, VX1 + vfmadd.d res1, VX0, VX0, res1 + vfmadd.d res2, VX1, VX1, res2 + vld VX2, X, 4 * SIZE + vld VX3, X, 4 * SIZE + vfcvtl.d.s VX2, VX2 + vfcvth.d.s VX3, VX3 + vfmadd.d res1, VX2, VX2, res1 + vfmadd.d res2, VX3, VX3, res2 + addi.d I, I, -1 + addi.d X, X, 8 * SIZE + blt $r0, I, .L10 + b .L996 + .align 3 + + +.L20: + bge $r0, I, .L997 + .align 3 + +.L21: + ld.w t1, X, 0 * SIZE + add.d X, X, INCX + ld.w t2, X, 0 * SIZE + add.d X, X, INCX + ld.w t3, X, 0 * SIZE + add.d X, X, INCX + ld.w t4, X, 0 * SIZE + add.d X, X, INCX + vinsgr2vr.w VX0, t1, 0 + vinsgr2vr.w VX0, t2, 1 + vinsgr2vr.w VX0, t3, 2 + vinsgr2vr.w VX0, t4, 3 + ld.w t1, X, 0 * SIZE + add.d X, X, INCX + ld.w t2, X, 0 * SIZE + add.d X, X, INCX + ld.w t3, X, 0 * SIZE + add.d X, X, INCX + ld.w t4, X, 0 * SIZE + add.d X, X, INCX + vinsgr2vr.w VX1, t1, 0 + vinsgr2vr.w VX1, t2, 1 + vinsgr2vr.w VX1, t3, 2 + vinsgr2vr.w VX1, t4, 3 + vfcvtl.d.s VX0, VX0 + vfcvth.d.s VX1, VX1 + vfmadd.d res1, VX0, VX0, res1 + vfmadd.d res2, VX1, VX1, res2 + ld.w t1, X, 0 * SIZE + add.d X, X, INCX + ld.w t2, X, 0 * SIZE + add.d X, X, INCX + ld.w t3, X, 0 * SIZE + add.d X, X, INCX + ld.w t4, X, 0 * SIZE + add.d X, X, INCX + vinsgr2vr.w VX2, t1, 0 + vinsgr2vr.w VX2, t2, 1 + vinsgr2vr.w VX2, t3, 2 + vinsgr2vr.w VX2, t4, 3 + ld.w t1, X, 0 * SIZE + add.d X, X, INCX + ld.w t2, X, 0 * SIZE + add.d X, X, INCX + ld.w t3, X, 0 * SIZE + add.d X, X, INCX + ld.w t4, X, 0 * SIZE + add.d X, X, INCX + vinsgr2vr.w VX3, t1, 0 + vinsgr2vr.w VX3, t2, 1 + vinsgr2vr.w VX3, t3, 2 + vinsgr2vr.w VX3, t4, 3 + vfcvtl.d.s VX2, VX2 + vfcvth.d.s VX3, VX3 + vfmadd.d res1, VX2, VX2, res1 + vfmadd.d res2, VX3, VX3, res2 + addi.d I, I, -1 + blt $r0, I, .L21 + b .L996 + .align 3 + +.L996: + vfadd.d res1, res1, res2 + vreplvei.w VX1, res1, 1 + vreplvei.w VX2, res1, 2 + vreplvei.w VX3, res1, 3 + vfadd.s res1, VX1, res1 + vfadd.s res1, VX2, res1 + vfadd.s res1, VX3, res1 + .align 3 + +.L997: + andi I, N, 7 + bge $r0, I, .L999 + .align 3 + +.L998: + fld.s $f15, X, 0 * SIZE + addi.d I, I, -1 + fcvt.d.s $f15, $f15 + fmadd.d $f19, $f15, $f15, $f19 + add.d X, X, INCX + blt $r0, I, .L998 + .align 3 + +.L999: + fsqrt.d $f19, $f19 + move $r4, $r17 + fcvt.s.d $f0, $f19 + jirl $r0, $r1, 0x0 + .align 3 + + EPILOGUE From edac80d7e8ba97e39002f223628a956456356fa9 Mon Sep 17 00:00:00 2001 From: Mark Seminatore Date: Thu, 7 Dec 2023 14:59:27 -0800 Subject: [PATCH 58/60] some cleanup, dynamically scale threads, add missing WIN_CASE defn --- driver/others/blas_server_win32.c | 70 ++++++++++++++++++++++--------- 1 file changed, 51 insertions(+), 19 deletions(-) diff --git a/driver/others/blas_server_win32.c b/driver/others/blas_server_win32.c index 5af1f1a51..40ff85abc 100644 --- a/driver/others/blas_server_win32.c +++ b/driver/others/blas_server_win32.c @@ -51,15 +51,6 @@ /* This is a thread implementation for Win32 lazy implementation */ /* Thread server common information */ -//typedef struct{ -// CRITICAL_SECTION lock; -// HANDLE filled; -// HANDLE killed; -// -// blas_queue_t *queue; /* Parameter Pointer */ -// int shutdown; /* server shutdown flag */ -// -//} blas_pool_t; static blas_queue_t *work_queue = NULL; static HANDLE kickoff_event = NULL; @@ -71,11 +62,19 @@ int blas_server_avail = 0; /* Local Variables */ static BLASULONG server_lock = 0; -//static blas_pool_t pool; static HANDLE blas_threads [MAX_CPU_NUMBER]; static DWORD blas_threads_id[MAX_CPU_NUMBER]; +static volatile int thread_target; // target num of live threads, volatile for cross-thread reads - +#if defined (__GNUC__) && (__GNUC__ < 6) + #define WIN_CAS(dest, exch, comp) __sync_val_compare_and_swap(dest, comp, exch) +#else + #if defined(_WIN64) + #define WIN_CAS(dest, exch, comp) InterlockedCompareExchange64(dest, exch, comp) + #else + #define WIN_CAS(dest, exch, comp) InterlockedCompareExchange(dest, exch, comp) + #endif +#endif static void legacy_exec(void *func, int mode, blas_arg_t *args, void *sb){ @@ -206,14 +205,10 @@ static void legacy_exec(void *func, int mode, blas_arg_t *args, void *sb){ static DWORD WINAPI blas_thread_server(void *arg){ /* Thread identifier */ -#ifdef SMP_DEBUG BLASLONG cpu = (BLASLONG)arg; -#endif void *buffer, *sa, *sb; blas_queue_t *queue; - DWORD action; - //HANDLE handles[] = {pool.filled, pool.killed}; /* Each server needs each buffer */ buffer = blas_memory_alloc(2); @@ -232,6 +227,12 @@ static DWORD WINAPI blas_thread_server(void *arg){ // event raised when work is added to the queue WaitForSingleObject(kickoff_event, INFINITE); + if (cpu > thread_target - 2) + { + //printf("thread [%d] exiting.\n", cpu); + break; // excess thread, so worker thread exits + } + #ifdef SMP_DEBUG fprintf(STDERR, "Server[%2ld] Got it.\n", cpu); #endif @@ -245,17 +246,17 @@ static DWORD WINAPI blas_thread_server(void *arg){ LeaveCriticalSection(&queue_lock); #else - volatile work_queue_t* queue_next; + volatile blas_queue_t* queue_next; INT_PTR prev_value; do { - queue = (volatile work_queue_t*)work_queue; + queue = (volatile blas_queue_t*)work_queue; if (!queue) break; - queue_next = (volatile work_queue_t*)queue->next; + queue_next = (volatile blas_queue_t*)queue->next; prev_value = WIN_CAS((INT_PTR*)&work_queue, (INT_PTR)queue_next, (INT_PTR)queue); - } while (prev_value != work_item); + } while (prev_value != queue); #endif if (queue) { @@ -377,9 +378,13 @@ int blas_thread_init(void){ // create the kickoff Event kickoff_event = CreateEvent(NULL, TRUE, FALSE, NULL); + thread_target = blas_cpu_number; + InitializeCriticalSection(&queue_lock); for(i = 0; i < blas_cpu_number - 1; i++){ + //printf("thread_init: creating thread [%d]\n", i); + blas_threads[i] = CreateThread(NULL, 0, blas_thread_server, (void *)i, 0, &blas_threads_id[i]); @@ -564,10 +569,36 @@ void goto_set_num_threads(int num_threads) if (num_threads > MAX_CPU_NUMBER) num_threads = MAX_CPU_NUMBER; + if (blas_server_avail && num_threads < blas_num_threads) { + LOCK_COMMAND(&server_lock); + + thread_target = num_threads; + + SetEvent(kickoff_event); + + for (i = num_threads - 1; i < blas_num_threads - 1; i++) { + //printf("set_num_threads: waiting on thread [%d] to quit.\n", i); + + WaitForSingleObject(blas_threads[i], INFINITE); + + //printf("set_num_threads: thread [%d] has quit.\n", i); + + CloseHandle(blas_threads[i]); + } + + blas_num_threads = num_threads; + + ResetEvent(kickoff_event); + + UNLOCK_COMMAND(&server_lock); + } + if (num_threads > blas_num_threads) { LOCK_COMMAND(&server_lock); + thread_target = num_threads; + //increased_threads = 1; if (!blas_server_avail){ // create the kickoff Event @@ -579,6 +610,7 @@ void goto_set_num_threads(int num_threads) } for(i = (blas_num_threads > 0) ? blas_num_threads - 1 : 0; i < num_threads - 1; i++){ + //printf("set_num_threads: creating thread [%d]\n", i); blas_threads[i] = CreateThread(NULL, 0, blas_thread_server, (void *)i, From c732f275a27cbd9044d8409c2dd13e1e32f675ca Mon Sep 17 00:00:00 2001 From: barracuda156 Date: Mon, 11 Dec 2023 21:05:31 +0800 Subject: [PATCH 59/60] system_check.cmake: fix arch detection for Darwin PowerPC --- cmake/system_check.cmake | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/cmake/system_check.cmake b/cmake/system_check.cmake index c9671b379..e94497a04 100644 --- a/cmake/system_check.cmake +++ b/cmake/system_check.cmake @@ -38,7 +38,7 @@ if(CMAKE_CL_64 OR MINGW64) endif() elseif(MINGW OR (MSVC AND NOT CMAKE_CROSSCOMPILING)) set(X86 1) -elseif(CMAKE_SYSTEM_PROCESSOR MATCHES "ppc.*|power.*|Power.*") +elseif(CMAKE_SYSTEM_PROCESSOR MATCHES "ppc.*|power.*|Power.*" OR (CMAKE_SYSTEM_NAME MATCHES "Darwin" AND CMAKE_OSX_ARCHITECTURES MATCHES "ppc.*")) set(POWER 1) elseif(CMAKE_SYSTEM_PROCESSOR MATCHES "mips64.*") set(MIPS64 1) @@ -109,7 +109,7 @@ else() endif () if (NOT BINARY) - if (X86_64 OR ARM64 OR POWER OR MIPS64 OR LOONGARCH64 OR RISCV64) + if (X86_64 OR ARM64 OR MIPS64 OR LOONGARCH64 OR RISCV64 OR (POWER AND NOT (CMAKE_OSX_ARCHITECTURES STREQUAL "ppc"))) set(BINARY 64) else () set(BINARY 32) From 9dbc8129b3987fd038585904e612a8ff0f62f947 Mon Sep 17 00:00:00 2001 From: barracuda156 Date: Mon, 11 Dec 2023 21:09:06 +0800 Subject: [PATCH 60/60] cpuid_power.c: add CPU_SUBTYPE_POWERPC_7400 case --- cpuid_power.c | 1 + 1 file changed, 1 insertion(+) diff --git a/cpuid_power.c b/cpuid_power.c index 2526e8d0e..1ced8930a 100644 --- a/cpuid_power.c +++ b/cpuid_power.c @@ -160,6 +160,7 @@ int detect(void){ infoCount = HOST_BASIC_INFO_COUNT; host_info(mach_host_self(), HOST_BASIC_INFO, (host_info_t)&hostInfo, &infoCount); + if (hostInfo.cpu_subtype == CPU_SUBTYPE_POWERPC_7400) return CPUTYPE_PPCG4; if (hostInfo.cpu_subtype == CPU_SUBTYPE_POWERPC_7450) return CPUTYPE_PPCG4; if (hostInfo.cpu_subtype == CPU_SUBTYPE_POWERPC_970) return CPUTYPE_PPC970;