From b8a644358e0c6e4b3c945591a4b5fa69ffa38eec Mon Sep 17 00:00:00 2001 From: Eduard Fedorenkov Date: Wed, 29 May 2024 18:49:34 +0700 Subject: [PATCH 01/16] develop DLARF1F and implement in ORM2R, #1011 --- SRC/CMakeLists.txt | 2 +- SRC/dlarf1f.f | 288 +++++++++++++++++++++++++++++++++++++++++++++ SRC/dorm2r.f | 8 +- 3 files changed, 291 insertions(+), 7 deletions(-) create mode 100644 SRC/dlarf1f.f diff --git a/SRC/CMakeLists.txt b/SRC/CMakeLists.txt index a2f396bae2..d368da2e15 100644 --- a/SRC/CMakeLists.txt +++ b/SRC/CMakeLists.txt @@ -307,7 +307,7 @@ set(DLASRC dlaqgb.f dlaqge.f dlaqp2.f dlaqps.f dlaqp2rk.f dlaqp3rk.f dlaqsb.f dlaqsp.f dlaqsy.f dlaqr0.f dlaqr1.f dlaqr2.f dlaqr3.f dlaqr4.f dlaqr5.f 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 + dlarf.f dlarf1f.f dlarfb.f dlarfb_gett.f dlarfg.f dlarfgp.f dlarft.f dlarfx.f dlarfy.f dlargv.f dlarmm.f dlarrv.f dlartv.f dlarz.f dlarzb.f dlarzt.f dlaswp.f dlasy2.f dlasyf.f dlasyf_rook.f dlasyf_rk.f dlasyf_aa.f diff --git a/SRC/dlarf1f.f b/SRC/dlarf1f.f new file mode 100644 index 0000000000..626e0db490 --- /dev/null +++ b/SRC/dlarf1f.f @@ -0,0 +1,288 @@ +*> \brief \b DLARF1F applies an elementary reflector to a general rectangular matrix. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLARF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLARF1F( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) +* +* .. Scalar Arguments .. +* CHARACTER SIDE +* INTEGER INCV, LDC, M, N +* DOUBLE PRECISION TAU +* .. +* .. Array Arguments .. +* DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLARF1F applies a real elementary reflector H to a real m by n matrix +*> C, from either the left or the right. H is represented in the form +*> +*> H = I - tau * v * v**T +*> +*> where tau is a real scalar and v is a real vector. +*> It is assumed that v(1) = 1. v(1) is not referenced. +*> +*> If tau = 0, then H is taken to be the unit matrix. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> = 'L': form H * C +*> = 'R': form C * H +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix C. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix C. +*> \endverbatim +*> +*> \param[in] V +*> \verbatim +*> V is DOUBLE PRECISION array, dimension +*> (1 + (M-1)*abs(INCV)) if SIDE = 'L' +*> or (1 + (N-1)*abs(INCV)) if SIDE = 'R' +*> The vector v in the representation of H. V is not used if +*> TAU = 0. +*> \endverbatim +*> +*> \param[in] INCV +*> \verbatim +*> INCV is INTEGER +*> The increment between elements of v. INCV <> 0. +*> \endverbatim +*> +*> \param[in] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION +*> The value tau in the representation of H. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is DOUBLE PRECISION array, dimension (LDC,N) +*> On entry, the m by n matrix C. +*> On exit, C is overwritten by the matrix H * C if SIDE = 'L', +*> or C * H if SIDE = 'R'. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,M). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension +*> (N) if SIDE = 'L' +*> or (M) if SIDE = 'R' +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup larf1f +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The algorithm update matrix C by blocks. +*> C is presected in the form of 4 blocks: +*> C11 - 1-by-1, C12 - 1-by-n, C21 - m-by-1 and C22 - (m-1)-by-(n-1) +*> +*> C = ( C11 | C12 ) +*> (_____|___________________) +*> ( | ) +*> ( | ) +*> ( C21 | C22 ) +*> ( | ) +*> ( | ) +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE DLARF1F( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) +* +* -- LAPACK auxiliary routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER SIDE + INTEGER INCV, LDC, M, N + DOUBLE PRECISION TAU +* .. +* .. Array Arguments .. + DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL APPLYLEFT + INTEGER I, LASTV, LASTC + DOUBLE PRECISION C11, DOT1, DDOT +* .. +* .. External Subroutines .. + EXTERNAL DGEMV, DGER, DDOT, DAXPY, DCOPY +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILADLR, ILADLC + EXTERNAL LSAME, ILADLR, ILADLC +* .. +* .. Executable Statements .. +* + APPLYLEFT = LSAME( SIDE, 'L' ) + LASTV = 0 + LASTC = 0 + IF( TAU.NE.ZERO ) THEN +! Set up variables for scanning V. LASTV begins pointing to the end +! of V. + IF( APPLYLEFT ) THEN + LASTV = M + ELSE + LASTV = N + END IF + IF( INCV.GT.0 ) THEN + I = 1 + (LASTV-1) * INCV + ELSE + I = 1 + END IF +! Look for the last non-zero row in V. + DO WHILE( LASTV.GT.0 .AND. V( I ).EQ.ZERO ) + LASTV = LASTV - 1 + I = I - INCV + END DO + IF( APPLYLEFT ) THEN +! Scan for the last non-zero column in C(1:lastv,:). + LASTC = ILADLC(LASTV, N, C, LDC) + ELSE +! Scan for the last non-zero row in C(:,1:lastv). + LASTC = ILADLR(M, LASTV, C, LDC) + END IF + END IF + + IF( LASTC.EQ.0 ) THEN + RETURN + END IF + + IF( APPLYLEFT ) THEN +* +* Form H * C +* + IF( LASTV.GT.0 ) THEN + DOT1 = - TAU * DDOT( LASTV - 1, V( 1 + INCV ), INCV, + $ C( 2, 1 ), 1 ) + + C11 = (ONE - TAU) * C( 1, 1 ) + DOT1 +* +* Prepare WORK +* + CALL DCOPY( LASTC - 1, C( 1, 2 ), LDC, WORK, 1 ) + + CALL DGEMV( 'Transpose', LASTV - 1, LASTC - 1, -TAU, + $ C( 2, 2 ), LDC, V( 1 + INCV ), INCV, -TAU, WORK, 1 ) +* +* Update C12 +* + CALL DAXPY( LASTC - 1, ONE, WORK, 1, C( 1, 2 ), LDC ) +* +* Update C21 +* + CALL DAXPY( LASTV - 1, -TAU * C( 1, 1 ) + DOT1, + $ V( 1 + INCV ), INCV, C( 2, 1 ), 1 ) +* +* Update C11 +* + C( 1, 1 ) = C11 +* +* Update C22 +* + CALL DGER( LASTV - 1, LASTC - 1, ONE, V( 1 + INCV ), + $ INCV, WORK, 1, C( 2, 2 ), LDC ) + END IF + ELSE +* +* Form C * H +* + IF( LASTV.GT.0 ) THEN + DOT1 = - TAU * DDOT( LASTV - 1, V( 1 + INCV ), INCV, + $ C( 1, 2 ), LDC ) + + C11 = (ONE - TAU) * C( 1, 1 ) + DOT1 +* +* Prepare WORK +* + CALL DCOPY( LASTC - 1, C( 2, 1 ), 1, WORK, 1 ) + + CALL DGEMV( 'No transpose', LASTC - 1, LASTV - 1, -TAU, + $ C( 2, 2 ), LDC, V( 1 + INCV ), INCV, -TAU, WORK, 1 ) +* +* Update C12 +* + CALL DAXPY( LASTV - 1, -TAU * C( 1, 1 ) + DOT1, + $ V( 1 + INCV ), INCV, C( 1, 2 ), LDC ) +* +* Update C11 +* + C( 1, 1 ) = C11 +* +* Update C21 +* + CALL DAXPY( LASTC - 1, ONE, WORK, 1, C( 2, 1 ), 1 ) +* +* Update C22 +* + CALL DGER( LASTC - 1, LASTV - 1, ONE, WORK, 1, + $ V( 1 + INCV ), INCV, C( 2, 2 ), LDC ) + END IF + END IF + RETURN +* +* End of DLARF1F +* + END diff --git a/SRC/dorm2r.f b/SRC/dorm2r.f index d894a806c3..334d12b1f7 100644 --- a/SRC/dorm2r.f +++ b/SRC/dorm2r.f @@ -178,14 +178,13 @@ SUBROUTINE DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, * .. Local Scalars .. LOGICAL LEFT, NOTRAN INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ - DOUBLE PRECISION AII * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. - EXTERNAL DLARF, XERBLA + EXTERNAL DLARF1F, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX @@ -266,12 +265,9 @@ SUBROUTINE DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, * * Apply H(i) * - AII = A( I, I ) - A( I, I ) = ONE - CALL DLARF( SIDE, MI, NI, A( I, I ), 1, TAU( I ), C( IC, + CALL DLARF1F( SIDE, MI, NI, A( I, I ), 1, TAU( I ), C( IC, $ JC ), $ LDC, WORK ) - A( I, I ) = AII 10 CONTINUE RETURN * From 0d2bff7886c43f1918c373b96284082f953e0492 Mon Sep 17 00:00:00 2001 From: Eduard Fedorenkov Date: Thu, 30 May 2024 15:37:46 +0700 Subject: [PATCH 02/16] fix DLARF1F in case lastv = 1, #1011 --- SRC/dlarf1f.f | 36 ++++++++++-------------------------- 1 file changed, 10 insertions(+), 26 deletions(-) diff --git a/SRC/dlarf1f.f b/SRC/dlarf1f.f index 626e0db490..a8c1cb9866 100644 --- a/SRC/dlarf1f.f +++ b/SRC/dlarf1f.f @@ -35,13 +35,12 @@ *> *> \verbatim *> -*> DLARF1F applies a real elementary reflector H to a real m by n matrix +*> DLARF applies a real elementary reflector H to a real m by n matrix *> C, from either the left or the right. H is represented in the form *> *> H = I - tau * v * v**T *> *> where tau is a real scalar and v is a real vector. -*> It is assumed that v(1) = 1. v(1) is not referenced. *> *> If tau = 0, then H is taken to be the unit matrix. *> \endverbatim @@ -118,26 +117,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \ingroup larf1f -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> The algorithm update matrix C by blocks. -*> C is presected in the form of 4 blocks: -*> C11 - 1-by-1, C12 - 1-by-n, C21 - m-by-1 and C22 - (m-1)-by-(n-1) -*> -*> C = ( C11 | C12 ) -*> (_____|___________________) -*> ( | ) -*> ( | ) -*> ( C21 | C22 ) -*> ( | ) -*> ( | ) -*> -*> \endverbatim +*> \ingroup larf * * ===================================================================== SUBROUTINE DLARF1F( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) @@ -167,7 +147,7 @@ SUBROUTINE DLARF1F( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) DOUBLE PRECISION C11, DOT1, DDOT * .. * .. External Subroutines .. - EXTERNAL DGEMV, DGER, DDOT, DAXPY, DCOPY + EXTERNAL DGEMV, DGER, DDOT, DAXPY, DCOPY, DSCAL * .. * .. External Functions .. LOGICAL LSAME @@ -206,7 +186,7 @@ SUBROUTINE DLARF1F( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) END IF END IF - IF( LASTC.EQ.0 ) THEN + IF( LASTC.EQ.0 .OR. LASTV.EQ.0 ) THEN RETURN END IF @@ -214,7 +194,9 @@ SUBROUTINE DLARF1F( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) * * Form H * C * - IF( LASTV.GT.0 ) THEN + IF( LASTV.EQ.1 ) THEN + CALL DSCAL(LASTC, ONE - TAU, C, LDC) + ELSE DOT1 = - TAU * DDOT( LASTV - 1, V( 1 + INCV ), INCV, $ C( 2, 1 ), 1 ) @@ -249,7 +231,9 @@ SUBROUTINE DLARF1F( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) * * Form C * H * - IF( LASTV.GT.0 ) THEN + IF( LASTV.EQ.1 ) THEN + CALL DSCAL(LASTC, ONE - TAU, C, 1) + ELSE DOT1 = - TAU * DDOT( LASTV - 1, V( 1 + INCV ), INCV, $ C( 1, 2 ), LDC ) From a4698c3c9c215af4241a541fb157f569f73ca967 Mon Sep 17 00:00:00 2001 From: Eduard Fedorenkov Date: Fri, 31 May 2024 17:15:51 +0700 Subject: [PATCH 03/16] align DLARF1F versions, #1011 --- SRC/Makefile | 2 +- SRC/dlarf1f.f | 84 ++++++++++++++++++++------------------------------- 2 files changed, 34 insertions(+), 52 deletions(-) diff --git a/SRC/Makefile b/SRC/Makefile index 5662d2ab00..5d73c59251 100644 --- a/SRC/Makefile +++ b/SRC/Makefile @@ -339,7 +339,7 @@ DLASRC = \ dlaqgb.o dlaqge.o dlaqp2.o dlaqps.o dlaqp2rk.o dlaqp3rk.o dlaqsb.o dlaqsp.o dlaqsy.o \ dlaqr0.o dlaqr1.o dlaqr2.o dlaqr3.o dlaqr4.o dlaqr5.o \ 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 \ + dlarf.o dlarf1f.o dlarfb.o dlarfb_gett.o dlarfg.o dlarfgp.o dlarft.o dlarfx.o dlarfy.o \ dlargv.o dlarmm.o dlarrv.o dlartv.o \ dlarz.o dlarzb.o dlarzt.o dlaswp.o dlasy2.o \ dlasyf.o dlasyf_rook.o dlasyf_rk.o \ diff --git a/SRC/dlarf1f.f b/SRC/dlarf1f.f index a8c1cb9866..33d242baa9 100644 --- a/SRC/dlarf1f.f +++ b/SRC/dlarf1f.f @@ -1,4 +1,5 @@ -*> \brief \b DLARF1F applies an elementary reflector to a general rectangular matrix. +*> \brief \b DLARF1F applies an elementary reflector to a general rectangular +* matrix assuming v(1) = 1. * * =========== DOCUMENTATION =========== * @@ -35,12 +36,12 @@ *> *> \verbatim *> -*> DLARF applies a real elementary reflector H to a real m by n matrix +*> DLARF1F applies a real elementary reflector H to a real m by n matrix *> C, from either the left or the right. H is represented in the form *> *> H = I - tau * v * v**T *> -*> where tau is a real scalar and v is a real vector. +*> where tau is a real scalar and v is a real vector assuming v(1) = 1. *> *> If tau = 0, then H is taken to be the unit matrix. *> \endverbatim @@ -117,7 +118,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \ingroup larf +*> \ingroup larf1f * * ===================================================================== SUBROUTINE DLARF1F( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) @@ -144,10 +145,9 @@ SUBROUTINE DLARF1F( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) * .. Local Scalars .. LOGICAL APPLYLEFT INTEGER I, LASTV, LASTC - DOUBLE PRECISION C11, DOT1, DDOT * .. * .. External Subroutines .. - EXTERNAL DGEMV, DGER, DDOT, DAXPY, DCOPY, DSCAL + EXTERNAL DGEMV, DGER, DAXPY * .. * .. External Functions .. LOGICAL LSAME @@ -185,84 +185,66 @@ SUBROUTINE DLARF1F( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) LASTC = ILADLR(M, LASTV, C, LDC) END IF END IF - IF( LASTC.EQ.0 .OR. LASTV.EQ.0 ) THEN RETURN END IF - IF( APPLYLEFT ) THEN * * Form H * C * IF( LASTV.EQ.1 ) THEN - CALL DSCAL(LASTC, ONE - TAU, C, LDC) - ELSE - DOT1 = - TAU * DDOT( LASTV - 1, V( 1 + INCV ), INCV, - $ C( 2, 1 ), 1 ) - - C11 = (ONE - TAU) * C( 1, 1 ) + DOT1 * -* Prepare WORK +* C(1,1:lastc) := ( 1 - tau ) * C(1,1:lastc) * - CALL DCOPY( LASTC - 1, C( 1, 2 ), LDC, WORK, 1 ) - - CALL DGEMV( 'Transpose', LASTV - 1, LASTC - 1, -TAU, - $ C( 2, 2 ), LDC, V( 1 + INCV ), INCV, -TAU, WORK, 1 ) + CALL DSCAL( LASTC, ONE - TAU, C, LDC ) + ELSE * -* Update C12 +* w(1:lastc,1) := C(2:lastv,1:lastc)**T * v(2:lastv,1) * - CALL DAXPY( LASTC - 1, ONE, WORK, 1, C( 1, 2 ), LDC ) + CALL DGEMV( 'Transpose', LASTV - 1, LASTC, ONE, C( 2, 1 ), + $ LDC, V( 1 + INCV ), INCV, ZERO, WORK, 1 ) * -* Update C21 +* w(1:lastc,1) += C(1,1:lastc)**T * v(1,1) * - CALL DAXPY( LASTV - 1, -TAU * C( 1, 1 ) + DOT1, - $ V( 1 + INCV ), INCV, C( 2, 1 ), 1 ) + CALL DAXPY( LASTC, ONE, C, LDC, WORK, 1 ) * -* Update C11 +* C(1, 1:lastc) := C(...) - tau * w(1:lastc,1)**T * - C( 1, 1 ) = C11 + CALL DAXPY( LASTC, -TAU, WORK, 1, C, LDC ) * -* Update C22 +* C(2:lastv,1:lastc) := C(...) - tau * v(2:lastv,1)*w(1:lastc,1)**T * - CALL DGER( LASTV - 1, LASTC - 1, ONE, V( 1 + INCV ), - $ INCV, WORK, 1, C( 2, 2 ), LDC ) - END IF + CALL DGER( LASTV - 1, LASTC, -TAU, V( 1 + INCV ), INCV, WORK, + $ 1, C( 2, 1 ), LDC ) + END IF ELSE * * Form C * H * IF( LASTV.EQ.1 ) THEN - CALL DSCAL(LASTC, ONE - TAU, C, 1) - ELSE - DOT1 = - TAU * DDOT( LASTV - 1, V( 1 + INCV ), INCV, - $ C( 1, 2 ), LDC ) - - C11 = (ONE - TAU) * C( 1, 1 ) + DOT1 * -* Prepare WORK +* C(1:lastc,1) := ( 1 - tau ) * C(1:lastc,1) * - CALL DCOPY( LASTC - 1, C( 2, 1 ), 1, WORK, 1 ) - - CALL DGEMV( 'No transpose', LASTC - 1, LASTV - 1, -TAU, - $ C( 2, 2 ), LDC, V( 1 + INCV ), INCV, -TAU, WORK, 1 ) + CALL DSCAL( LASTC, ONE - TAU, C, 1 ) + ELSE * -* Update C12 +* w(1:lastc,1) := C(1:lastc,2:lastv) * v(2:lastv,1) * - CALL DAXPY( LASTV - 1, -TAU * C( 1, 1 ) + DOT1, - $ V( 1 + INCV ), INCV, C( 1, 2 ), LDC ) + CALL DGEMV( 'No transpose', LASTC, LASTV - 1, ONE, + $ C( 1, 2 ), LDC, V( 1 + INCV ), INCV, ZERO, WORK, 1 ) * -* Update C11 +* w(1:lastc,1) += C(1:lastc,1) * v(1,1) * - C( 1, 1 ) = C11 + CALL DAXPY( LASTC, ONE, C, 1, WORK, 1 ) * -* Update C21 +* C(1:lastc,1) := C(1:lastc,1) - tau * w(1:lastc,1) * - CALL DAXPY( LASTC - 1, ONE, WORK, 1, C( 2, 1 ), 1 ) + CALL DAXPY( LASTC, -TAU, WORK, 1, C, 1 ) * -* Update C22 +* C(1:lastc,2:lastv) := C(1:lastc,2:lastv) - tau * w(1:lastc,1) * v(2:lastv)**T * - CALL DGER( LASTC - 1, LASTV - 1, ONE, WORK, 1, - $ V( 1 + INCV ), INCV, C( 2, 2 ), LDC ) + CALL DGER( LASTC, LASTV - 1, -TAU, WORK, 1, V( 1 + INCV ), + $ INCV, C( 1, 2 ), LDC ) END IF END IF RETURN From 5e7dad37c9190ccf7d8ddd6c6195e7fb0efeb564 Mon Sep 17 00:00:00 2001 From: Eduard Fedorenkov Date: Mon, 3 Jun 2024 15:23:37 +0700 Subject: [PATCH 04/16] remove dlarf1f prototype and add slarf1f, slarf1l, #1011 --- SRC/CMakeLists.txt | 4 +- SRC/Makefile | 4 +- SRC/dorm2r.f | 8 +- SRC/{dlarf1f.f => slarf1f.f} | 88 ++++++------ SRC/slarf1l.f | 256 +++++++++++++++++++++++++++++++++++ SRC/sorm2l.f | 8 +- SRC/sorm2r.f | 11 +- 7 files changed, 315 insertions(+), 64 deletions(-) rename SRC/{dlarf1f.f => slarf1f.f} (67%) create mode 100644 SRC/slarf1l.f diff --git a/SRC/CMakeLists.txt b/SRC/CMakeLists.txt index d368da2e15..ba83a6bcb0 100644 --- a/SRC/CMakeLists.txt +++ b/SRC/CMakeLists.txt @@ -106,7 +106,7 @@ set(SLASRC 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 + slarf.f slarf1f.f slarf1l.f slarfb.f slarfb_gett.f slarfg.f slarfgp.f slarft.f slarfx.f slarfy.f slargv.f slarmm.f slarrv.f slartv.f slarz.f slarzb.f slarzt.f slasy2.f slasyf.f slasyf_rook.f slasyf_rk.f slasyf_aa.f @@ -307,7 +307,7 @@ set(DLASRC dlaqgb.f dlaqge.f dlaqp2.f dlaqps.f dlaqp2rk.f dlaqp3rk.f dlaqsb.f dlaqsp.f dlaqsy.f dlaqr0.f dlaqr1.f dlaqr2.f dlaqr3.f dlaqr4.f dlaqr5.f dlaqtr.f dlar1v.f dlar2v.f iladlr.f iladlc.f - dlarf.f dlarf1f.f dlarfb.f dlarfb_gett.f dlarfg.f dlarfgp.f dlarft.f dlarfx.f dlarfy.f + dlarf.f dlarfb.f dlarfb_gett.f dlarfg.f dlarfgp.f dlarft.f dlarfx.f dlarfy.f dlargv.f dlarmm.f dlarrv.f dlartv.f dlarz.f dlarzb.f dlarzt.f dlaswp.f dlasy2.f dlasyf.f dlasyf_rook.f dlasyf_rk.f dlasyf_aa.f diff --git a/SRC/Makefile b/SRC/Makefile index 5d73c59251..4c3867f686 100644 --- a/SRC/Makefile +++ b/SRC/Makefile @@ -137,7 +137,7 @@ SLASRC = \ slaqgb.o slaqge.o slaqp2.o slaqps.o slaqp2rk.o slaqp3rk.o slaqsb.o slaqsp.o slaqsy.o \ slaqr0.o slaqr1.o slaqr2.o slaqr3.o slaqr4.o slaqr5.o \ slaqtr.o slar1v.o slar2v.o ilaslr.o ilaslc.o \ - slarf.o slarfb.o slarfb_gett.o slarfg.o slarfgp.o slarft.o slarfx.o slarfy.o \ + slarf.o slarf1f.o slarf1l.o slarfb.o slarfb_gett.o slarfg.o slarfgp.o slarft.o slarfx.o slarfy.o \ slargv.o slarmm.o slarrv.o slartv.o \ slarz.o slarzb.o slarzt.o slaswp.o slasy2.o slasyf.o slasyf_rook.o \ slasyf_rk.o \ @@ -339,7 +339,7 @@ DLASRC = \ dlaqgb.o dlaqge.o dlaqp2.o dlaqps.o dlaqp2rk.o dlaqp3rk.o dlaqsb.o dlaqsp.o dlaqsy.o \ dlaqr0.o dlaqr1.o dlaqr2.o dlaqr3.o dlaqr4.o dlaqr5.o \ dlaqtr.o dlar1v.o dlar2v.o iladlr.o iladlc.o \ - dlarf.o dlarf1f.o dlarfb.o dlarfb_gett.o dlarfg.o dlarfgp.o dlarft.o dlarfx.o dlarfy.o \ + dlarf.o dlarfb.o dlarfb_gett.o dlarfg.o dlarfgp.o dlarft.o dlarfx.o dlarfy.o \ dlargv.o dlarmm.o dlarrv.o dlartv.o \ dlarz.o dlarzb.o dlarzt.o dlaswp.o dlasy2.o \ dlasyf.o dlasyf_rook.o dlasyf_rk.o \ diff --git a/SRC/dorm2r.f b/SRC/dorm2r.f index 334d12b1f7..d894a806c3 100644 --- a/SRC/dorm2r.f +++ b/SRC/dorm2r.f @@ -178,13 +178,14 @@ SUBROUTINE DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, * .. Local Scalars .. LOGICAL LEFT, NOTRAN INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ + DOUBLE PRECISION AII * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. - EXTERNAL DLARF1F, XERBLA + EXTERNAL DLARF, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX @@ -265,9 +266,12 @@ SUBROUTINE DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, * * Apply H(i) * - CALL DLARF1F( SIDE, MI, NI, A( I, I ), 1, TAU( I ), C( IC, + AII = A( I, I ) + A( I, I ) = ONE + CALL DLARF( SIDE, MI, NI, A( I, I ), 1, TAU( I ), C( IC, $ JC ), $ LDC, WORK ) + A( I, I ) = AII 10 CONTINUE RETURN * diff --git a/SRC/dlarf1f.f b/SRC/slarf1f.f similarity index 67% rename from SRC/dlarf1f.f rename to SRC/slarf1f.f index 33d242baa9..493e57bb21 100644 --- a/SRC/dlarf1f.f +++ b/SRC/slarf1f.f @@ -1,4 +1,4 @@ -*> \brief \b DLARF1F applies an elementary reflector to a general rectangular +*> \brief \b SLARF1F applies an elementary reflector to a general rectangular * matrix assuming v(1) = 1. * * =========== DOCUMENTATION =========== @@ -7,27 +7,27 @@ * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLARF + dependencies -*> +*> Download SLARF1F + dependencies +*> *> [TGZ] -*> +*> *> [ZIP] -*> +*> *> [TXT] *> \endhtmlonly * * Definition: * =========== * -* SUBROUTINE DLARF1F( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) +* SUBROUTINE SLARF1F( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) * * .. Scalar Arguments .. * CHARACTER SIDE * INTEGER INCV, LDC, M, N -* DOUBLE PRECISION TAU +* REAL TAU * .. * .. Array Arguments .. -* DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * ) +* REAL C( LDC, * ), V( * ), WORK( * ) * .. * * @@ -36,7 +36,7 @@ *> *> \verbatim *> -*> DLARF1F applies a real elementary reflector H to a real m by n matrix +*> SLARF1F applies a real elementary reflector H to a real m by n matrix *> C, from either the left or the right. H is represented in the form *> *> H = I - tau * v * v**T @@ -70,7 +70,7 @@ *> *> \param[in] V *> \verbatim -*> V is DOUBLE PRECISION array, dimension +*> V is REAL array, dimension *> (1 + (M-1)*abs(INCV)) if SIDE = 'L' *> or (1 + (N-1)*abs(INCV)) if SIDE = 'R' *> The vector v in the representation of H. V is not used if @@ -85,13 +85,13 @@ *> *> \param[in] TAU *> \verbatim -*> TAU is DOUBLE PRECISION +*> TAU is REAL *> The value tau in the representation of H. *> \endverbatim *> *> \param[in,out] C *> \verbatim -*> C is DOUBLE PRECISION array, dimension (LDC,N) +*> C is REAL array, dimension (LDC,N) *> On entry, the m by n matrix C. *> On exit, C is overwritten by the matrix H * C if SIDE = 'L', *> or C * H if SIDE = 'R'. @@ -105,7 +105,7 @@ *> *> \param[out] WORK *> \verbatim -*> WORK is DOUBLE PRECISION array, dimension +*> WORK is REAL array, dimension *> (N) if SIDE = 'L' *> or (M) if SIDE = 'R' *> \endverbatim @@ -121,7 +121,7 @@ *> \ingroup larf1f * * ===================================================================== - SUBROUTINE DLARF1F( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) + SUBROUTINE SLARF1F( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) * * -- LAPACK auxiliary routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -130,29 +130,29 @@ SUBROUTINE DLARF1F( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) * .. Scalar Arguments .. CHARACTER SIDE INTEGER INCV, LDC, M, N - DOUBLE PRECISION TAU + REAL TAU * .. * .. Array Arguments .. - DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * ) + REAL C( LDC, * ), V( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) + REAL ONE, ZERO + PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) * .. * .. Local Scalars .. LOGICAL APPLYLEFT INTEGER I, LASTV, LASTC * .. * .. External Subroutines .. - EXTERNAL DGEMV, DGER, DAXPY + EXTERNAL SGEMV, SGER, SAXPY, SSCAL * .. * .. External Functions .. LOGICAL LSAME - INTEGER ILADLR, ILADLC - EXTERNAL LSAME, ILADLR, ILADLC + INTEGER ILASLR, ILASLC + EXTERNAL LSAME, ILASLR, ILASLC * .. * .. Executable Statements .. * @@ -179,10 +179,10 @@ SUBROUTINE DLARF1F( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) END DO IF( APPLYLEFT ) THEN ! Scan for the last non-zero column in C(1:lastv,:). - LASTC = ILADLC(LASTV, N, C, LDC) + LASTC = ILASLC(LASTV, N, C, LDC) ELSE ! Scan for the last non-zero row in C(:,1:lastv). - LASTC = ILADLR(M, LASTV, C, LDC) + LASTC = ILASLR(M, LASTV, C, LDC) END IF END IF IF( LASTC.EQ.0 .OR. LASTV.EQ.0 ) THEN @@ -196,26 +196,26 @@ SUBROUTINE DLARF1F( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) * * C(1,1:lastc) := ( 1 - tau ) * C(1,1:lastc) * - CALL DSCAL( LASTC, ONE - TAU, C, LDC ) + CALL SSCAL( LASTC, ONE - TAU, C, LDC ) ELSE * * w(1:lastc,1) := C(2:lastv,1:lastc)**T * v(2:lastv,1) * - CALL DGEMV( 'Transpose', LASTV - 1, LASTC, ONE, C( 2, 1 ), - $ LDC, V( 1 + INCV ), INCV, ZERO, WORK, 1 ) + CALL SGEMV( 'Transpose', LASTV - 1, LASTC, ONE, C( 2, 1 ), + $ LDC, V( 1 + INCV ), INCV, ZERO, WORK, 1 ) * -* w(1:lastc,1) += C(1,1:lastc)**T * v(1,1) +* w(1:lastc,1) += v(1,1) * C(1,1:lastc)**T * - CALL DAXPY( LASTC, ONE, C, LDC, WORK, 1 ) + CALL SAXPY( LASTC, ONE, C, LDC, WORK, 1 ) * -* C(1, 1:lastc) := C(...) - tau * w(1:lastc,1)**T +* C(1, 1:lastc) += - tau * v(1,1) * w(1:lastc,1)**T * - CALL DAXPY( LASTC, -TAU, WORK, 1, C, LDC ) + CALL SAXPY( LASTC, -TAU, WORK, 1, C, LDC ) * -* C(2:lastv,1:lastc) := C(...) - tau * v(2:lastv,1)*w(1:lastc,1)**T +* C(2:lastv,1:lastc) += - tau * v(2:lastv,1) * w(1:lastc,1)**T * - CALL DGER( LASTV - 1, LASTC, -TAU, V( 1 + INCV ), INCV, WORK, - $ 1, C( 2, 1 ), LDC ) + CALL SGER( LASTV - 1, LASTC, -TAU, V( 1 + INCV ), INCV, WORK, + $ 1, C( 2, 1 ), LDC ) END IF ELSE * @@ -225,30 +225,30 @@ SUBROUTINE DLARF1F( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) * * C(1:lastc,1) := ( 1 - tau ) * C(1:lastc,1) * - CALL DSCAL( LASTC, ONE - TAU, C, 1 ) + CALL SSCAL( LASTC, ONE - TAU, C, 1 ) ELSE * * w(1:lastc,1) := C(1:lastc,2:lastv) * v(2:lastv,1) * - CALL DGEMV( 'No transpose', LASTC, LASTV - 1, ONE, - $ C( 1, 2 ), LDC, V( 1 + INCV ), INCV, ZERO, WORK, 1 ) + CALL SGEMV( 'No transpose', LASTC, LASTV - 1, ONE, + $ C( 1, 2 ), LDC, V( 1 + INCV ), INCV, ZERO, WORK, 1 ) * -* w(1:lastc,1) += C(1:lastc,1) * v(1,1) +* w(1:lastc,1) += v(1,1) * C(1:lastc,1) * - CALL DAXPY( LASTC, ONE, C, 1, WORK, 1 ) + CALL SAXPY( LASTC, ONE, C, 1, WORK, 1 ) * -* C(1:lastc,1) := C(1:lastc,1) - tau * w(1:lastc,1) +* C(1:lastc,1) += - tau * v(1,1) * w(1:lastc,1) * - CALL DAXPY( LASTC, -TAU, WORK, 1, C, 1 ) + CALL SAXPY( LASTC, -TAU, WORK, 1, C, 1 ) * -* C(1:lastc,2:lastv) := C(1:lastc,2:lastv) - tau * w(1:lastc,1) * v(2:lastv)**T +* C(1:lastc,2:lastv) += - tau * w(1:lastc,1) * v(2:lastv)**T * - CALL DGER( LASTC, LASTV - 1, -TAU, WORK, 1, V( 1 + INCV ), - $ INCV, C( 1, 2 ), LDC ) + CALL SGER( LASTC, LASTV - 1, -TAU, WORK, 1, + $ V( 1 + INCV ), INCV, C( 1, 2 ), LDC ) END IF END IF RETURN * -* End of DLARF1F +* End of SLARF1F * END diff --git a/SRC/slarf1l.f b/SRC/slarf1l.f new file mode 100644 index 0000000000..901b01dce2 --- /dev/null +++ b/SRC/slarf1l.f @@ -0,0 +1,256 @@ +*> \brief \b SLARF1L applies an elementary reflector to a general rectangular +* matrix assuming v(lastv) = 1, where lastv is the last non-zero +* element +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download SLARF1L + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE SLARF1L( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) +* +* .. Scalar Arguments .. +* CHARACTER SIDE +* INTEGER INCV, LDC, M, N +* REAL TAU +* .. +* .. Array Arguments .. +* REAL C( LDC, * ), V( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SLARF1L applies a real elementary reflector H to a real m by n matrix +*> C, from either the left or the right. H is represented in the form +*> +*> H = I - tau * v * v**T +*> +*> where tau is a real scalar and v is a real vector assuming v(lastv) = 1, +*> where lastv is the last non-zero element. +*> +*> If tau = 0, then H is taken to be the unit matrix. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> = 'L': form H * C +*> = 'R': form C * H +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix C. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix C. +*> \endverbatim +*> +*> \param[in] V +*> \verbatim +*> V is REAL array, dimension +*> (1 + (M-1)*abs(INCV)) if SIDE = 'L' +*> or (1 + (N-1)*abs(INCV)) if SIDE = 'R' +*> The vector v in the representation of H. V is not used if +*> TAU = 0. +*> \endverbatim +*> +*> \param[in] INCV +*> \verbatim +*> INCV is INTEGER +*> The increment between elements of v. INCV <> 0. +*> \endverbatim +*> +*> \param[in] TAU +*> \verbatim +*> TAU is REAL +*> The value tau in the representation of H. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is REAL array, dimension (LDC,N) +*> On entry, the m by n matrix C. +*> On exit, C is overwritten by the matrix H * C if SIDE = 'L', +*> or C * H if SIDE = 'R'. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,M). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is REAL array, dimension +*> (N) if SIDE = 'L' +*> or (M) if SIDE = 'R' +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup larf1l +* +* ===================================================================== + SUBROUTINE SLARF1L( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) +* +* -- LAPACK auxiliary routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER SIDE + INTEGER INCV, LDC, M, N + REAL TAU +* .. +* .. Array Arguments .. + REAL C( LDC, * ), V( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ONE, ZERO + PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) +* .. +* .. Local Scalars .. + LOGICAL APPLYLEFT + INTEGER I, LASTV, LASTC +* .. +* .. External Subroutines .. + EXTERNAL SGEMV, SGER, SAXPY, SSCAL +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILASLR, ILASLC + EXTERNAL LSAME, ILASLR, ILASLC +* .. +* .. Executable Statements .. +* + APPLYLEFT = LSAME( SIDE, 'L' ) + LASTV = 0 + LASTC = 0 + IF( TAU.NE.ZERO ) THEN +! Set up variables for scanning V. LASTV begins pointing to the end +! of V. + IF( APPLYLEFT ) THEN + LASTV = M + ELSE + LASTV = N + END IF + IF( INCV.GT.0 ) THEN + I = 1 + (LASTV-1) * INCV + ELSE + I = 1 + END IF +! Look for the last non-zero row in V. + DO WHILE( LASTV.GT.0 .AND. V( I ).EQ.ZERO ) + LASTV = LASTV - 1 + I = I - INCV + END DO + IF( APPLYLEFT ) THEN +! Scan for the last non-zero column in C(1:lastv,:). + LASTC = ILASLC(LASTV, N, C, LDC) + ELSE +! Scan for the last non-zero row in C(:,1:lastv). + LASTC = ILASLR(M, LASTV, C, LDC) + END IF + END IF + IF( LASTC.EQ.0 .OR. LASTV.EQ.0 ) THEN + RETURN + END IF + IF( APPLYLEFT ) THEN +* +* Form H * C +* + IF( LASTV.EQ.1 ) THEN +* +* C(1,1:lastc) := ( 1 - tau ) * C(1,1:lastc) +* + CALL SSCAL( LASTC, ONE - TAU, C, LDC ) + ELSE +* +* w(1:lastc,1) := C(1:lastv-1,1:lastc)**T * v(1:lastv-1,1) +* + CALL SGEMV( 'Transpose', LASTV - 1, LASTC, ONE, C, LDC, + $ V, INCV, ZERO, WORK, 1 ) +* +* w(1:lastc,1) += C(lastv,1:lastc)**T * v(lastv,1) +* + CALL SAXPY( LASTC, ONE, C( LASTV, 1 ), LDC, WORK, 1 ) +* +* C(lastv,1:lastc) += - tau * v(lastv,1) * w(1:lastc,1)**T +* + CALL SAXPY( LASTC, -TAU, WORK, 1, C( LASTV, 1 ), LDC ) +* +* C(1:lastv-1,1:lastc) += - tau * v(1:lastv-1,1) * w(1:lastc,1)**T +* + CALL SGER( LASTV - 1, LASTC, -TAU, V, INCV, WORK, 1, C, + $ LDC) + END IF + ELSE +* +* Form C * H +* + IF( LASTV.EQ.1 ) THEN +* +* C(1:lastc,1) := ( 1 - tau ) * C(1:lastc,1) +* + CALL SSCAL( LASTC, ONE - TAU, C, 1 ) + ELSE +* +* w(1:lastc,1) := C(1:lastc,1:lastv-1) * v(1:lastv-1,1) +* + CALL SGEMV( 'No transpose', LASTC, LASTV - 1, ONE, C, + $ LDC, V, INCV, ZERO, WORK, 1 ) +* +* w(1:lastc,1) += C(1:lastc,lastv) * v(lastv,1) +* + CALL SAXPY( LASTC, ONE, C( 1, LASTV ), 1, WORK, 1 ) +* +* C(1:lastc,lastv) += - tau * v(lastv,1) * w(1:lastc,1) +* + CALL SAXPY( LASTC, -TAU, WORK, 1, C( 1, LASTV ), 1 ) +* +* C(1:lastc,1:lastv-1) += - tau * w(1:lastc,1) * v(1:lastv-1)**T +* + CALL SGER( LASTC, LASTV - 1, -TAU, WORK, 1, V, + $ INCV, C, LDC ) + END IF + END IF + RETURN +* +* End of SLARF1L +* + END diff --git a/SRC/sorm2l.f b/SRC/sorm2l.f index bdd883c6c7..ff2e0b1c87 100644 --- a/SRC/sorm2l.f +++ b/SRC/sorm2l.f @@ -178,14 +178,13 @@ SUBROUTINE SORM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, * .. Local Scalars .. LOGICAL LEFT, NOTRAN INTEGER I, I1, I2, I3, MI, NI, NQ - REAL AII * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. - EXTERNAL SLARF, XERBLA + EXTERNAL SLARF1L, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX @@ -262,11 +261,8 @@ SUBROUTINE SORM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, * * Apply H(i) * - AII = A( NQ-K+I, I ) - A( NQ-K+I, I ) = ONE - CALL SLARF( SIDE, MI, NI, A( 1, I ), 1, TAU( I ), C, LDC, + CALL SLARF1L( SIDE, MI, NI, A( 1, I ), 1, TAU( I ), C, LDC, $ WORK ) - A( NQ-K+I, I ) = AII 10 CONTINUE RETURN * diff --git a/SRC/sorm2r.f b/SRC/sorm2r.f index 4f53cbd3a0..360770a5bf 100644 --- a/SRC/sorm2r.f +++ b/SRC/sorm2r.f @@ -178,14 +178,13 @@ SUBROUTINE SORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, * .. Local Scalars .. LOGICAL LEFT, NOTRAN INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ - REAL AII * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. - EXTERNAL SLARF, XERBLA + EXTERNAL SLARF1F, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX @@ -266,12 +265,8 @@ SUBROUTINE SORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, * * Apply H(i) * - AII = A( I, I ) - A( I, I ) = ONE - CALL SLARF( SIDE, MI, NI, A( I, I ), 1, TAU( I ), C( IC, - $ JC ), - $ LDC, WORK ) - A( I, I ) = AII + CALL SLARF1F( SIDE, MI, NI, A( I, I ), 1, TAU( I ), C( IC, + $ JC ), LDC, WORK ) 10 CONTINUE RETURN * From 8dd7e138a9aadc22124781499f7239c35b1ce31e Mon Sep 17 00:00:00 2001 From: Eduard Fedorenkov Date: Tue, 4 Jun 2024 16:56:49 +0700 Subject: [PATCH 05/16] update single precision routines to use slarf1f and slarf1l, #1011 --- SRC/sgebd2.f | 30 +++++------- SRC/sgehd2.f | 14 ++---- SRC/sgelq2.f | 12 ++--- SRC/sgeql2.f | 12 ++--- SRC/sgeqp3rk.f | 4 +- SRC/sgeqr2.f | 10 ++-- SRC/sgeqr2p.f | 10 ++-- SRC/sgerq2.f | 10 ++-- SRC/slaqp2.f | 11 ++--- SRC/slaqp2rk.f | 13 ++--- SRC/slaqr2.f | 21 ++++---- SRC/slaqr3.f | 21 ++++---- SRC/sopmtr.f | 19 +++----- SRC/sorbdb.f | 128 +++++++++++++++++++++++-------------------------- SRC/sorbdb1.f | 22 ++++----- SRC/sorbdb2.f | 27 +++++------ SRC/sorbdb3.f | 30 +++++------- SRC/sorbdb4.f | 51 +++++++++----------- SRC/sorg2l.f | 8 ++-- SRC/sorg2r.f | 7 ++- SRC/sorgl2.f | 7 ++- SRC/sorgr2.f | 8 ++-- SRC/sorml2.f | 10 ++-- SRC/sormr2.f | 11 ++--- 24 files changed, 208 insertions(+), 288 deletions(-) diff --git a/SRC/sgebd2.f b/SRC/sgebd2.f index 978ec9f369..c0ff242297 100644 --- a/SRC/sgebd2.f +++ b/SRC/sgebd2.f @@ -209,7 +209,7 @@ SUBROUTINE SGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO ) INTEGER I * .. * .. External Subroutines .. - EXTERNAL SLARF, SLARFG, XERBLA + EXTERNAL SLARF1F, SLARFG, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN @@ -242,15 +242,13 @@ SUBROUTINE SGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO ) CALL SLARFG( M-I+1, A( I, I ), A( MIN( I+1, M ), I ), 1, $ TAUQ( I ) ) D( I ) = A( I, I ) - A( I, I ) = ONE * * Apply H(i) to A(i:m,i+1:n) from the left * IF( I.LT.N ) - $ CALL SLARF( 'Left', M-I+1, N-I, A( I, I ), 1, - $ TAUQ( I ), - $ A( I, I+1 ), LDA, WORK ) - A( I, I ) = D( I ) + $ CALL SLARF1F( 'Left', M-I+1, N-I, A( I, I ), 1, + $ TAUQ( I ), + $ A( I, I+1 ), LDA, WORK ) * IF( I.LT.N ) THEN * @@ -260,13 +258,11 @@ SUBROUTINE SGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO ) CALL SLARFG( N-I, A( I, I+1 ), A( I, MIN( I+2, N ) ), $ LDA, TAUP( I ) ) E( I ) = A( I, I+1 ) - A( I, I+1 ) = ONE * * Apply G(i) to A(i+1:m,i+1:n) from the right * - CALL SLARF( 'Right', M-I, N-I, A( I, I+1 ), LDA, - $ TAUP( I ), A( I+1, I+1 ), LDA, WORK ) - A( I, I+1 ) = E( I ) + CALL SLARF1F( 'Right', M-I, N-I, A( I, I+1 ), LDA, + $ TAUP( I ), A( I+1, I+1 ), LDA, WORK ) ELSE TAUP( I ) = ZERO END IF @@ -283,14 +279,12 @@ SUBROUTINE SGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO ) $ LDA, $ TAUP( I ) ) D( I ) = A( I, I ) - A( I, I ) = ONE * * Apply G(i) to A(i+1:m,i:n) from the right * IF( I.LT.M ) - $ CALL SLARF( 'Right', M-I, N-I+1, A( I, I ), LDA, - $ TAUP( I ), A( I+1, I ), LDA, WORK ) - A( I, I ) = D( I ) + $ CALL SLARF1F( 'Right', M-I, N-I+1, A( I, I ), LDA, + $ TAUP( I ), A( I+1, I ), LDA, WORK ) * IF( I.LT.M ) THEN * @@ -301,14 +295,12 @@ SUBROUTINE SGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO ) $ 1, $ TAUQ( I ) ) E( I ) = A( I+1, I ) - A( I+1, I ) = ONE * * Apply H(i) to A(i+1:m,i+1:n) from the left * - CALL SLARF( 'Left', M-I, N-I, A( I+1, I ), 1, - $ TAUQ( I ), - $ A( I+1, I+1 ), LDA, WORK ) - A( I+1, I ) = E( I ) + CALL SLARF1F( 'Left', M-I, N-I, A( I+1, I ), 1, + $ TAUQ( I ), + $ A( I+1, I+1 ), LDA, WORK ) ELSE TAUQ( I ) = ZERO END IF diff --git a/SRC/sgehd2.f b/SRC/sgehd2.f index 2692e68273..e513502130 100644 --- a/SRC/sgehd2.f +++ b/SRC/sgehd2.f @@ -166,10 +166,9 @@ SUBROUTINE SGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO ) * .. * .. Local Scalars .. INTEGER I - REAL AII * .. * .. External Subroutines .. - EXTERNAL SLARF, SLARFG, XERBLA + EXTERNAL SLARF1F, SLARFG, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN @@ -199,20 +198,17 @@ SUBROUTINE SGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO ) * CALL SLARFG( IHI-I, A( I+1, I ), A( MIN( I+2, N ), I ), 1, $ TAU( I ) ) - AII = A( I+1, I ) - A( I+1, I ) = ONE * * Apply H(i) to A(1:ihi,i+1:ihi) from the right * - CALL SLARF( 'Right', IHI, IHI-I, A( I+1, I ), 1, TAU( I ), - $ A( 1, I+1 ), LDA, WORK ) + CALL SLARF1F( 'Right', IHI, IHI-I, A( I+1, I ), 1, TAU( I ), + $ A( 1, I+1 ), LDA, WORK ) * * Apply H(i) to A(i+1:ihi,i+1:n) from the left * - CALL SLARF( 'Left', IHI-I, N-I, A( I+1, I ), 1, TAU( I ), - $ A( I+1, I+1 ), LDA, WORK ) + CALL SLARF1F( 'Left', IHI-I, N-I, A( I+1, I ), 1, TAU( I ), + $ A( I+1, I+1 ), LDA, WORK ) * - A( I+1, I ) = AII 10 CONTINUE * RETURN diff --git a/SRC/sgelq2.f b/SRC/sgelq2.f index 14c345bf39..3e431c3927 100644 --- a/SRC/sgelq2.f +++ b/SRC/sgelq2.f @@ -146,10 +146,9 @@ SUBROUTINE SGELQ2( M, N, A, LDA, TAU, WORK, INFO ) * .. * .. Local Scalars .. INTEGER I, K - REAL AII * .. * .. External Subroutines .. - EXTERNAL SLARF, SLARFG, XERBLA + EXTERNAL SLARF1F, SLARFG, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN @@ -183,12 +182,9 @@ SUBROUTINE SGELQ2( M, N, A, LDA, TAU, WORK, INFO ) * * Apply H(i) to A(i+1:m,i:n) from the right * - AII = A( I, I ) - A( I, I ) = ONE - CALL SLARF( 'Right', M-I, N-I+1, A( I, I ), LDA, - $ TAU( I ), - $ A( I+1, I ), LDA, WORK ) - A( I, I ) = AII + CALL SLARF1F( 'Right', M-I, N-I+1, A( I, I ), LDA, + $ TAU( I ), + $ A( I+1, I ), LDA, WORK ) END IF 10 CONTINUE RETURN diff --git a/SRC/sgeql2.f b/SRC/sgeql2.f index c727c3611f..ec58dc2269 100644 --- a/SRC/sgeql2.f +++ b/SRC/sgeql2.f @@ -140,10 +140,9 @@ SUBROUTINE SGEQL2( M, N, A, LDA, TAU, WORK, INFO ) * .. * .. Local Scalars .. INTEGER I, K - REAL AII * .. * .. External Subroutines .. - EXTERNAL SLARF, SLARFG, XERBLA + EXTERNAL SLARF1L, SLARFG, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN @@ -177,12 +176,9 @@ SUBROUTINE SGEQL2( M, N, A, LDA, TAU, WORK, INFO ) * * Apply H(i) to A(1:m-k+i,1:n-k+i-1) from the left * - AII = A( M-K+I, N-K+I ) - A( M-K+I, N-K+I ) = ONE - CALL SLARF( 'Left', M-K+I, N-K+I-1, A( 1, N-K+I ), 1, - $ TAU( I ), - $ A, LDA, WORK ) - A( M-K+I, N-K+I ) = AII + CALL SLARF1L( 'Left', M-K+I, N-K+I-1, A( 1, N-K+I ), 1, + $ TAU( I ), + $ A, LDA, WORK ) 10 CONTINUE RETURN * diff --git a/SRC/sgeqp3rk.f b/SRC/sgeqp3rk.f index e5b3e4cd86..191cbcffab 100644 --- a/SRC/sgeqp3rk.f +++ b/SRC/sgeqp3rk.f @@ -671,7 +671,7 @@ SUBROUTINE SGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, A, LDA, * 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 +* in SLARF1F subroutine inside SLAQP2RK to apply an * elementary reflector from the left. * TOTAL_WORK_SIZE = 3*N + NRHS - 1 * @@ -687,7 +687,7 @@ SUBROUTINE SGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, A, LDA, * 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 +* in SLARF1F 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 diff --git a/SRC/sgeqr2.f b/SRC/sgeqr2.f index 3a78733b7d..1868b204c6 100644 --- a/SRC/sgeqr2.f +++ b/SRC/sgeqr2.f @@ -147,10 +147,9 @@ SUBROUTINE SGEQR2( M, N, A, LDA, TAU, WORK, INFO ) * .. * .. Local Scalars .. INTEGER I, K - REAL AII * .. * .. External Subroutines .. - EXTERNAL SLARF, SLARFG, XERBLA + EXTERNAL SLARF1F, SLARFG, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN @@ -184,11 +183,8 @@ SUBROUTINE SGEQR2( M, N, A, LDA, TAU, WORK, INFO ) * * Apply H(i) to A(i:m,i+1:n) from the left * - AII = A( I, I ) - A( I, I ) = ONE - CALL SLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ), - $ A( I, I+1 ), LDA, WORK ) - A( I, I ) = AII + CALL SLARF1F( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ), + $ A( I, I+1 ), LDA, WORK ) END IF 10 CONTINUE RETURN diff --git a/SRC/sgeqr2p.f b/SRC/sgeqr2p.f index 9f3693a631..02fe30826d 100644 --- a/SRC/sgeqr2p.f +++ b/SRC/sgeqr2p.f @@ -151,10 +151,9 @@ SUBROUTINE SGEQR2P( M, N, A, LDA, TAU, WORK, INFO ) * .. * .. Local Scalars .. INTEGER I, K - REAL AII * .. * .. External Subroutines .. - EXTERNAL SLARF, SLARFGP, XERBLA + EXTERNAL SLARF1F, SLARFGP, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN @@ -188,11 +187,8 @@ SUBROUTINE SGEQR2P( M, N, A, LDA, TAU, WORK, INFO ) * * Apply H(i) to A(i:m,i+1:n) from the left * - AII = A( I, I ) - A( I, I ) = ONE - CALL SLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ), - $ A( I, I+1 ), LDA, WORK ) - A( I, I ) = AII + CALL SLARF1F( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ), + $ A( I, I+1 ), LDA, WORK ) END IF 10 CONTINUE RETURN diff --git a/SRC/sgerq2.f b/SRC/sgerq2.f index 1c612f8f27..036f979cb5 100644 --- a/SRC/sgerq2.f +++ b/SRC/sgerq2.f @@ -140,10 +140,9 @@ SUBROUTINE SGERQ2( M, N, A, LDA, TAU, WORK, INFO ) * .. * .. Local Scalars .. INTEGER I, K - REAL AII * .. * .. External Subroutines .. - EXTERNAL SLARF, SLARFG, XERBLA + EXTERNAL SLARF1L, SLARFG, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN @@ -177,11 +176,8 @@ SUBROUTINE SGERQ2( M, N, A, LDA, TAU, WORK, INFO ) * * Apply H(i) to A(1:m-k+i-1,1:n-k+i) from the right * - AII = A( M-K+I, N-K+I ) - A( M-K+I, N-K+I ) = ONE - CALL SLARF( 'Right', M-K+I-1, N-K+I, A( M-K+I, 1 ), LDA, - $ TAU( I ), A, LDA, WORK ) - A( M-K+I, N-K+I ) = AII + CALL SLARF1L( 'Right', M-K+I-1, N-K+I, A( M-K+I, 1 ), LDA, + $ TAU( I ), A, LDA, WORK ) 10 CONTINUE RETURN * diff --git a/SRC/slaqp2.f b/SRC/slaqp2.f index c88e2e5e85..22e296b008 100644 --- a/SRC/slaqp2.f +++ b/SRC/slaqp2.f @@ -168,10 +168,10 @@ SUBROUTINE SLAQP2( M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2, * .. * .. Local Scalars .. INTEGER I, ITEMP, J, MN, OFFPI, PVT - REAL AII, TEMP, TEMP2, TOL3Z + REAL TEMP, TEMP2, TOL3Z * .. * .. External Subroutines .. - EXTERNAL SLARF, SLARFG, SSWAP + EXTERNAL SLARF1F, SLARFG, SSWAP * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, SQRT @@ -219,11 +219,8 @@ SUBROUTINE SLAQP2( M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2, * * Apply H(i)**T to A(offset+i:m,i+1:n) from the left. * - AII = A( OFFPI, I ) - A( OFFPI, I ) = ONE - CALL SLARF( 'Left', M-OFFPI+1, N-I, A( OFFPI, I ), 1, - $ TAU( I ), A( OFFPI, I+1 ), LDA, WORK( 1 ) ) - A( OFFPI, I ) = AII + CALL SLARF1F( 'Left', M-OFFPI+1, N-I, A( OFFPI, I ), 1, + $ TAU( I ), A( OFFPI, I+1 ), LDA, WORK( 1 ) ) END IF * * Update partial column norms. diff --git a/SRC/slaqp2rk.f b/SRC/slaqp2rk.f index f88b0ce909..3a19c5d746 100644 --- a/SRC/slaqp2rk.f +++ b/SRC/slaqp2rk.f @@ -253,7 +253,7 @@ *> \param[out] WORK *> \verbatim *> WORK is REAL array, dimension (N-1) -*> Used in SLARF subroutine to apply an elementary +*> Used in SLARF1F subroutine to apply an elementary *> reflector from the left. *> \endverbatim *> @@ -367,10 +367,10 @@ SUBROUTINE SLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, * .. Local Scalars .. INTEGER I, ITEMP, J, JMAXC2NRM, KK, KP, MINMNFACT, $ MINMNUPDT - REAL AIKK, HUGEVAL, TEMP, TEMP2, TOL3Z + REAL HUGEVAL, TEMP, TEMP2, TOL3Z * .. * .. External Subroutines .. - EXTERNAL SLARF, SLARFG, SSWAP + EXTERNAL SLARF1F, SLARFG, SSWAP * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, SQRT @@ -621,11 +621,8 @@ SUBROUTINE SLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, * 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 + CALL SLARF1F( 'Left', M-I+1, N+NRHS-KK, A( I, KK ), 1, + $ TAU( KK ), A( I, KK+1 ), LDA, WORK( 1 ) ) END IF * IF( KK.LT.MINMNFACT ) THEN diff --git a/SRC/slaqr2.f b/SRC/slaqr2.f index cc160b9bf3..e60eb80fea 100644 --- a/SRC/slaqr2.f +++ b/SRC/slaqr2.f @@ -298,7 +298,7 @@ SUBROUTINE SLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, PARAMETER ( ZERO = 0.0e0, ONE = 1.0e0 ) * .. * .. Local Scalars .. - REAL AA, BB, BETA, CC, CS, DD, EVI, EVK, FOO, S, + REAL AA, BB, CC, CS, DD, EVI, EVK, FOO, S, $ SAFMAX, SAFMIN, SMLNUM, SN, TAU, ULP INTEGER I, IFST, ILST, INFO, INFQR, J, JW, K, KCOL, $ KEND, KLN, KROW, KWTOP, LTOP, LWK1, LWK2, @@ -312,7 +312,8 @@ SUBROUTINE SLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, * .. External Subroutines .. EXTERNAL SCOPY, SGEHRD, SGEMM, SLACPY, $ SLAHQR, - $ SLANV2, SLARF, SLARFG, SLASET, SORMHR, STREXC + $ SLANV2, SLARF1L, SLARFG, SLASET, SORMHR, + $ STREXC * .. * .. Intrinsic Functions .. INTRINSIC ABS, INT, MAX, MIN, REAL, SQRT @@ -595,19 +596,17 @@ SUBROUTINE SLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, * ==== Reflect spike back into lower triangle ==== * CALL SCOPY( NS, V, LDV, WORK, 1 ) - BETA = WORK( 1 ) - CALL SLARFG( NS, BETA, WORK( 2 ), 1, TAU ) - WORK( 1 ) = ONE + CALL SLARFG( NS, WORK( 1 ), WORK( 2 ), 1, TAU ) * CALL SLASET( 'L', JW-2, JW-2, ZERO, ZERO, T( 3, 1 ), $ LDT ) * - CALL SLARF( 'L', NS, JW, WORK, 1, TAU, T, LDT, - $ WORK( JW+1 ) ) - CALL SLARF( 'R', NS, NS, WORK, 1, TAU, T, LDT, - $ WORK( JW+1 ) ) - CALL SLARF( 'R', JW, NS, WORK, 1, TAU, V, LDV, - $ WORK( JW+1 ) ) + CALL SLARF1F( 'L', NS, JW, WORK, 1, TAU, T, LDT, + $ WORK( JW+1 ) ) + CALL SLARF1F( 'R', NS, NS, WORK, 1, TAU, T, LDT, + $ WORK( JW+1 ) ) + CALL SLARF1F( 'R', JW, NS, WORK, 1, TAU, V, LDV, + $ WORK( JW+1 ) ) * CALL SGEHRD( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ), $ LWORK-JW, INFO ) diff --git a/SRC/slaqr3.f b/SRC/slaqr3.f index 7e53564a2b..21b958f308 100644 --- a/SRC/slaqr3.f +++ b/SRC/slaqr3.f @@ -295,7 +295,7 @@ SUBROUTINE SLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, PARAMETER ( ZERO = 0.0e0, ONE = 1.0e0 ) * .. * .. Local Scalars .. - REAL AA, BB, BETA, CC, CS, DD, EVI, EVK, FOO, S, + REAL AA, BB, CC, CS, DD, EVI, EVK, FOO, S, $ SAFMAX, SAFMIN, SMLNUM, SN, TAU, ULP INTEGER I, IFST, ILST, INFO, INFQR, J, JW, K, KCOL, $ KEND, KLN, KROW, KWTOP, LTOP, LWK1, LWK2, LWK3, @@ -310,7 +310,8 @@ SUBROUTINE SLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, * .. External Subroutines .. EXTERNAL SCOPY, SGEHRD, SGEMM, SLACPY, SLAHQR, $ SLANV2, - $ SLAQR4, SLARF, SLARFG, SLASET, SORMHR, STREXC + $ SLAQR4, SLARF1F, SLARFG, SLASET, SORMHR, + $ STREXC * .. * .. Intrinsic Functions .. INTRINSIC ABS, INT, MAX, MIN, REAL, SQRT @@ -606,19 +607,17 @@ SUBROUTINE SLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, * ==== Reflect spike back into lower triangle ==== * CALL SCOPY( NS, V, LDV, WORK, 1 ) - BETA = WORK( 1 ) - CALL SLARFG( NS, BETA, WORK( 2 ), 1, TAU ) - WORK( 1 ) = ONE + CALL SLARFG( NS, WORK( 1 ), WORK( 2 ), 1, TAU ) * CALL SLASET( 'L', JW-2, JW-2, ZERO, ZERO, T( 3, 1 ), $ LDT ) * - CALL SLARF( 'L', NS, JW, WORK, 1, TAU, T, LDT, - $ WORK( JW+1 ) ) - CALL SLARF( 'R', NS, NS, WORK, 1, TAU, T, LDT, - $ WORK( JW+1 ) ) - CALL SLARF( 'R', JW, NS, WORK, 1, TAU, V, LDV, - $ WORK( JW+1 ) ) + CALL SLARF1F( 'L', NS, JW, WORK, 1, TAU, T, LDT, + $ WORK( JW+1 ) ) + CALL SLARF1F( 'R', NS, NS, WORK, 1, TAU, T, LDT, + $ WORK( JW+1 ) ) + CALL SLARF1F( 'R', JW, NS, WORK, 1, TAU, V, LDV, + $ WORK( JW+1 ) ) * CALL SGEHRD( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ), $ LWORK-JW, INFO ) diff --git a/SRC/sopmtr.f b/SRC/sopmtr.f index e8542f3473..14749c29d7 100644 --- a/SRC/sopmtr.f +++ b/SRC/sopmtr.f @@ -170,14 +170,13 @@ SUBROUTINE SOPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC, * .. Local Scalars .. LOGICAL FORWRD, LEFT, NOTRAN, UPPER INTEGER I, I1, I2, I3, IC, II, JC, MI, NI, NQ - REAL AII * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. - EXTERNAL SLARF, XERBLA + EXTERNAL SLARF1F, SLARF1L, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX @@ -261,12 +260,9 @@ SUBROUTINE SOPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC, * * Apply H(i) * - AII = AP( II ) - AP( II ) = ONE - CALL SLARF( SIDE, MI, NI, AP( II-I+1 ), 1, TAU( I ), C, - $ LDC, - $ WORK ) - AP( II ) = AII + CALL SLARF1L( SIDE, MI, NI, AP( II-I+1 ), 1, TAU( I ), C, + $ LDC, + $ WORK ) * IF( FORWRD ) THEN II = II + I + 2 @@ -302,8 +298,6 @@ SUBROUTINE SOPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC, END IF * DO 20 I = I1, I2, I3 - AII = AP( II ) - AP( II ) = ONE IF( LEFT ) THEN * * H(i) is applied to C(i+1:m,1:n) @@ -320,9 +314,8 @@ SUBROUTINE SOPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC, * * Apply H(i) * - CALL SLARF( SIDE, MI, NI, AP( II ), 1, TAU( I ), - $ C( IC, JC ), LDC, WORK ) - AP( II ) = AII + CALL SLARF1F( SIDE, MI, NI, AP( II ), 1, TAU( I ), + $ C( IC, JC ), LDC, WORK ) * IF( FORWRD ) THEN II = II + NQ - I + 1 diff --git a/SRC/sorbdb.f b/SRC/sorbdb.f index 46f7a496a3..a401342e1c 100644 --- a/SRC/sorbdb.f +++ b/SRC/sorbdb.f @@ -316,7 +316,7 @@ SUBROUTINE SORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, REAL Z1, Z2, Z3, Z4 * .. * .. External Subroutines .. - EXTERNAL SAXPY, SLARF, SLARFGP, SSCAL, + EXTERNAL SAXPY, SLARF1F, SLARFGP, SSCAL, $ XERBLA * .. * .. External Functions .. @@ -422,7 +422,6 @@ SUBROUTINE SORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, ELSE IF( P .EQ. I ) THEN CALL SLARFGP( P-I+1, X11(I,I), X11(I,I), 1, TAUP1(I) ) END IF - X11(I,I) = ONE IF ( M-P .GT. I ) THEN CALL SLARFGP( M-P-I+1, X21(I,I), X21(I+1,I), 1, $ TAUP2(I) ) @@ -430,25 +429,25 @@ SUBROUTINE SORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, CALL SLARFGP( M-P-I+1, X21(I,I), X21(I,I), 1, $ TAUP2(I) ) END IF - X21(I,I) = ONE * IF ( Q .GT. I ) THEN - CALL SLARF( 'L', P-I+1, Q-I, X11(I,I), 1, TAUP1(I), - $ X11(I,I+1), LDX11, WORK ) + CALL SLARF1F( 'L', P-I+1, Q-I, X11(I,I), 1, TAUP1(I), + $ X11(I,I+1), LDX11, WORK ) END IF IF ( M-Q+1 .GT. I ) THEN - CALL SLARF( 'L', P-I+1, M-Q-I+1, X11(I,I), 1, - $ TAUP1(I), - $ X12(I,I), LDX12, WORK ) + CALL SLARF1F( 'L', P-I+1, M-Q-I+1, X11(I,I), 1, + $ TAUP1(I), + $ X12(I,I), LDX12, WORK ) END IF IF ( Q .GT. I ) THEN - CALL SLARF( 'L', M-P-I+1, Q-I, X21(I,I), 1, TAUP2(I), - $ X21(I,I+1), LDX21, WORK ) + CALL SLARF1F( 'L', M-P-I+1, Q-I, X21(I,I), 1, + $ TAUP2(I), + $ X21(I,I+1), LDX21, WORK ) END IF IF ( M-Q+1 .GT. I ) THEN - CALL SLARF( 'L', M-P-I+1, M-Q-I+1, X21(I,I), 1, - $ TAUP2(I), - $ X22(I,I), LDX22, WORK ) + CALL SLARF1F( 'L', M-P-I+1, M-Q-I+1, X21(I,I), 1, + $ TAUP2(I), + $ X22(I,I), LDX22, WORK ) END IF * IF( I .LT. Q ) THEN @@ -476,7 +475,6 @@ SUBROUTINE SORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, CALL SLARFGP( Q-I, X11(I,I+1), X11(I,I+2), LDX11, $ TAUQ1(I) ) END IF - X11(I,I+1) = ONE END IF IF ( Q+I-1 .LT. M ) THEN IF ( M-Q .EQ. I ) THEN @@ -487,24 +485,23 @@ SUBROUTINE SORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, $ TAUQ2(I) ) END IF END IF - X12(I,I) = ONE * IF( I .LT. Q ) THEN - CALL SLARF( 'R', P-I, Q-I, X11(I,I+1), LDX11, - $ TAUQ1(I), - $ X11(I+1,I+1), LDX11, WORK ) - CALL SLARF( 'R', M-P-I, Q-I, X11(I,I+1), LDX11, - $ TAUQ1(I), - $ X21(I+1,I+1), LDX21, WORK ) + CALL SLARF1F( 'R', P-I, Q-I, X11(I,I+1), LDX11, + $ TAUQ1(I), + $ X11(I+1,I+1), LDX11, WORK ) + CALL SLARF1F( 'R', M-P-I, Q-I, X11(I,I+1), LDX11, + $ TAUQ1(I), + $ X21(I+1,I+1), LDX21, WORK ) END IF IF ( P .GT. I ) THEN - CALL SLARF( 'R', P-I, M-Q-I+1, X12(I,I), LDX12, - $ TAUQ2(I), - $ X12(I+1,I), LDX12, WORK ) + CALL SLARF1F( 'R', P-I, M-Q-I+1, X12(I,I), LDX12, + $ TAUQ2(I), + $ X12(I+1,I), LDX12, WORK ) END IF IF ( M-P .GT. I ) THEN - CALL SLARF( 'R', M-P-I, M-Q-I+1, X12(I,I), LDX12, - $ TAUQ2(I), X22(I+1,I), LDX22, WORK ) + CALL SLARF1F( 'R', M-P-I, M-Q-I+1, X12(I,I), LDX12, + $ TAUQ2(I), X22(I+1,I), LDX22, WORK ) END IF * END DO @@ -521,16 +518,15 @@ SUBROUTINE SORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, CALL SLARFGP( M-Q-I+1, X12(I,I), X12(I,I+1), LDX12, $ TAUQ2(I) ) END IF - X12(I,I) = ONE * IF ( P .GT. I ) THEN - CALL SLARF( 'R', P-I, M-Q-I+1, X12(I,I), LDX12, - $ TAUQ2(I), - $ X12(I+1,I), LDX12, WORK ) + CALL SLARF1F( 'R', P-I, M-Q-I+1, X12(I,I), LDX12, + $ TAUQ2(I), + $ X12(I+1,I), LDX12, WORK ) END IF IF( M-P-Q .GE. 1 ) - $ CALL SLARF( 'R', M-P-Q, M-Q-I+1, X12(I,I), LDX12, - $ TAUQ2(I), X22(Q+1,I), LDX22, WORK ) + $ CALL SLARF1F( 'R', M-P-Q, M-Q-I+1, X12(I,I), LDX12, + $ TAUQ2(I), X22(Q+1,I), LDX22, WORK ) * END DO * @@ -546,11 +542,10 @@ SUBROUTINE SORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, CALL SLARFGP( M-P-Q-I+1, X22(Q+I,P+I), X22(Q+I,P+I+1), $ LDX22, TAUQ2(P+I) ) END IF - X22(Q+I,P+I) = ONE IF ( I .LT. M-P-Q ) THEN - CALL SLARF( 'R', M-P-Q-I, M-P-Q-I+1, X22(Q+I,P+I), - $ LDX22, - $ TAUQ2(P+I), X22(Q+I+1,P+I), LDX22, WORK ) + CALL SLARF1F( 'R', M-P-Q-I, M-P-Q-I+1, X22(Q+I,P+I), + $ LDX22, TAUQ2(P+I), X22(Q+I+1,P+I), + $ LDX22, WORK ) END IF * END DO @@ -584,7 +579,6 @@ SUBROUTINE SORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, * CALL SLARFGP( P-I+1, X11(I,I), X11(I,I+1), LDX11, $ TAUP1(I) ) - X11(I,I) = ONE IF ( I .EQ. M-P ) THEN CALL SLARFGP( M-P-I+1, X21(I,I), X21(I,I), LDX21, $ TAUP2(I) ) @@ -592,25 +586,24 @@ SUBROUTINE SORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, CALL SLARFGP( M-P-I+1, X21(I,I), X21(I,I+1), LDX21, $ TAUP2(I) ) END IF - X21(I,I) = ONE * IF ( Q .GT. I ) THEN - CALL SLARF( 'R', Q-I, P-I+1, X11(I,I), LDX11, - $ TAUP1(I), - $ X11(I+1,I), LDX11, WORK ) + CALL SLARF1F( 'R', Q-I, P-I+1, X11(I,I), LDX11, + $ TAUP1(I), + $ X11(I+1,I), LDX11, WORK ) END IF IF ( M-Q+1 .GT. I ) THEN - CALL SLARF( 'R', M-Q-I+1, P-I+1, X11(I,I), LDX11, - $ TAUP1(I), X12(I,I), LDX12, WORK ) + CALL SLARF1F( 'R', M-Q-I+1, P-I+1, X11(I,I), LDX11, + $ TAUP1(I), X12(I,I), LDX12, WORK ) END IF IF ( Q .GT. I ) THEN - CALL SLARF( 'R', Q-I, M-P-I+1, X21(I,I), LDX21, - $ TAUP2(I), - $ X21(I+1,I), LDX21, WORK ) + CALL SLARF1F( 'R', Q-I, M-P-I+1, X21(I,I), LDX21, + $ TAUP2(I), + $ X21(I+1,I), LDX21, WORK ) END IF IF ( M-Q+1 .GT. I ) THEN - CALL SLARF( 'R', M-Q-I+1, M-P-I+1, X21(I,I), LDX21, - $ TAUP2(I), X22(I,I), LDX22, WORK ) + CALL SLARF1F( 'R', M-Q-I+1, M-P-I+1, X21(I,I), LDX21, + $ TAUP2(I), X22(I,I), LDX22, WORK ) END IF * IF( I .LT. Q ) THEN @@ -634,7 +627,6 @@ SUBROUTINE SORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, CALL SLARFGP( Q-I, X11(I+1,I), X11(I+2,I), 1, $ TAUQ1(I) ) END IF - X11(I+1,I) = ONE END IF IF ( M-Q .GT. I ) THEN CALL SLARFGP( M-Q-I+1, X12(I,I), X12(I+1,I), 1, @@ -643,20 +635,19 @@ SUBROUTINE SORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, CALL SLARFGP( M-Q-I+1, X12(I,I), X12(I,I), 1, $ TAUQ2(I) ) END IF - X12(I,I) = ONE * IF( I .LT. Q ) THEN - CALL SLARF( 'L', Q-I, P-I, X11(I+1,I), 1, TAUQ1(I), - $ X11(I+1,I+1), LDX11, WORK ) - CALL SLARF( 'L', Q-I, M-P-I, X11(I+1,I), 1, TAUQ1(I), - $ X21(I+1,I+1), LDX21, WORK ) + CALL SLARF1F( 'L', Q-I, P-I, X11(I+1,I), 1, TAUQ1(I), + $ X11(I+1,I+1), LDX11, WORK ) + CALL SLARF1F( 'L', Q-I, M-P-I, X11(I+1,I), 1, TAUQ1(I), + $ X21(I+1,I+1), LDX21, WORK ) END IF - CALL SLARF( 'L', M-Q-I+1, P-I, X12(I,I), 1, TAUQ2(I), - $ X12(I,I+1), LDX12, WORK ) + CALL SLARF1F( 'L', M-Q-I+1, P-I, X12(I,I), 1, TAUQ2(I), + $ X12(I,I+1), LDX12, WORK ) IF ( M-P-I .GT. 0 ) THEN - CALL SLARF( 'L', M-Q-I+1, M-P-I, X12(I,I), 1, - $ TAUQ2(I), - $ X22(I,I+1), LDX22, WORK ) + CALL SLARF1F( 'L', M-Q-I+1, M-P-I, X12(I,I), 1, + $ TAUQ2(I), + $ X22(I,I+1), LDX22, WORK ) END IF * END DO @@ -668,16 +659,16 @@ SUBROUTINE SORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, CALL SSCAL( M-Q-I+1, -Z1*Z4, X12(I,I), 1 ) CALL SLARFGP( M-Q-I+1, X12(I,I), X12(I+1,I), 1, $ TAUQ2(I) ) - X12(I,I) = ONE * IF ( P .GT. I ) THEN - CALL SLARF( 'L', M-Q-I+1, P-I, X12(I,I), 1, TAUQ2(I), - $ X12(I,I+1), LDX12, WORK ) + CALL SLARF1F( 'L', M-Q-I+1, P-I, X12(I,I), 1, + $ TAUQ2(I), + $ X12(I,I+1), LDX12, WORK ) END IF IF( M-P-Q .GE. 1 ) - $ CALL SLARF( 'L', M-Q-I+1, M-P-Q, X12(I,I), 1, - $ TAUQ2(I), - $ X22(I,Q+1), LDX22, WORK ) + $ CALL SLARF1F( 'L', M-Q-I+1, M-P-Q, X12(I,I), 1, + $ TAUQ2(I), + $ X22(I,Q+1), LDX22, WORK ) * END DO * @@ -690,14 +681,13 @@ SUBROUTINE SORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, CALL SLARFGP( M-P-Q-I+1, X22(P+I,Q+I), X22(P+I,Q+I), $ 1, $ TAUQ2(P+I) ) - X22(P+I,Q+I) = ONE ELSE CALL SLARFGP( M-P-Q-I+1, X22(P+I,Q+I), X22(P+I+1,Q+I), $ 1, $ TAUQ2(P+I) ) - X22(P+I,Q+I) = ONE - CALL SLARF( 'L', M-P-Q-I+1, M-P-Q-I, X22(P+I,Q+I), 1, - $ TAUQ2(P+I), X22(P+I,Q+I+1), LDX22, WORK ) + CALL SLARF1F( 'L', M-P-Q-I+1, M-P-Q-I, X22(P+I,Q+I), + $ 1, TAUQ2(P+I), X22(P+I,Q+I+1), + $ LDX22, WORK ) END IF * * diff --git a/SRC/sorbdb1.f b/SRC/sorbdb1.f index 20e38371e0..1ce1bc8a6d 100644 --- a/SRC/sorbdb1.f +++ b/SRC/sorbdb1.f @@ -228,7 +228,7 @@ SUBROUTINE SORBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, LOGICAL LQUERY * .. * .. External Subroutines .. - EXTERNAL SLARF, SLARFGP, SORBDB5, SROT, + EXTERNAL SLARF1F, SLARFGP, SORBDB5, SROT, $ XERBLA * .. * .. External Functions .. @@ -287,12 +287,10 @@ SUBROUTINE SORBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, THETA(I) = ATAN2( X21(I,I), X11(I,I) ) C = COS( THETA(I) ) S = SIN( THETA(I) ) - X11(I,I) = ONE - X21(I,I) = ONE - CALL SLARF( 'L', P-I+1, Q-I, X11(I,I), 1, TAUP1(I), X11(I, - $ I+1), - $ LDX11, WORK(ILARF) ) - CALL SLARF( 'L', M-P-I+1, Q-I, X21(I,I), 1, TAUP2(I), + CALL SLARF1F( 'L', P-I+1, Q-I, X11(I,I), 1, TAUP1(I), X11(I, + $ I+1), + $ LDX11, WORK(ILARF) ) + CALL SLARF1F( 'L', M-P-I+1, Q-I, X21(I,I), 1, TAUP2(I), $ X21(I,I+1), LDX21, WORK(ILARF) ) * IF( I .LT. Q ) THEN @@ -301,11 +299,11 @@ SUBROUTINE SORBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, CALL SLARFGP( Q-I, X21(I,I+1), X21(I,I+2), LDX21, $ TAUQ1(I) ) S = X21(I,I+1) - X21(I,I+1) = ONE - CALL SLARF( 'R', P-I, Q-I, X21(I,I+1), LDX21, TAUQ1(I), - $ X11(I+1,I+1), LDX11, WORK(ILARF) ) - CALL SLARF( 'R', M-P-I, Q-I, X21(I,I+1), LDX21, TAUQ1(I), - $ X21(I+1,I+1), LDX21, WORK(ILARF) ) + CALL SLARF1F( 'R', P-I, Q-I, X21(I,I+1), LDX21, TAUQ1(I), + $ X11(I+1,I+1), LDX11, WORK(ILARF) ) + CALL SLARF1F( 'R', M-P-I, Q-I, X21(I,I+1), LDX21, + $ TAUQ1(I), + $ X21(I+1,I+1), LDX21, WORK(ILARF) ) C = SQRT( SNRM2( P-I, X11(I+1,I+1), 1 )**2 $ + SNRM2( M-P-I, X21(I+1,I+1), 1 )**2 ) PHI(I) = ATAN2( S, C ) diff --git a/SRC/sorbdb2.f b/SRC/sorbdb2.f index 02f6611a86..c785305c8c 100644 --- a/SRC/sorbdb2.f +++ b/SRC/sorbdb2.f @@ -226,7 +226,7 @@ SUBROUTINE SORBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, LOGICAL LQUERY * .. * .. External Subroutines .. - EXTERNAL SLARF, SLARFGP, SORBDB5, SROT, SSCAL, + EXTERNAL SLARF1F, SLARFGP, SORBDB5, SROT, SSCAL, $ XERBLA * .. * .. External Functions .. @@ -286,11 +286,11 @@ SUBROUTINE SORBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, END IF CALL SLARFGP( Q-I+1, X11(I,I), X11(I,I+1), LDX11, TAUQ1(I) ) C = X11(I,I) - X11(I,I) = ONE - CALL SLARF( 'R', P-I, Q-I+1, X11(I,I), LDX11, TAUQ1(I), - $ X11(I+1,I), LDX11, WORK(ILARF) ) - CALL SLARF( 'R', M-P-I+1, Q-I+1, X11(I,I), LDX11, TAUQ1(I), - $ X21(I,I), LDX21, WORK(ILARF) ) + CALL SLARF1F( 'R', P-I, Q-I+1, X11(I,I), LDX11, TAUQ1(I), + $ X11(I+1,I), LDX11, WORK(ILARF) ) + CALL SLARF1F( 'R', M-P-I+1, Q-I+1, X11(I,I), LDX11, + $ TAUQ1(I), + $ X21(I,I), LDX21, WORK(ILARF) ) S = SQRT( SNRM2( P-I, X11(I+1,I), 1 )**2 $ + SNRM2( M-P-I+1, X21(I,I), 1 )**2 ) THETA(I) = ATAN2( S, C ) @@ -305,13 +305,11 @@ SUBROUTINE SORBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI(I) = ATAN2( X11(I+1,I), X21(I,I) ) C = COS( PHI(I) ) S = SIN( PHI(I) ) - X11(I+1,I) = ONE - CALL SLARF( 'L', P-I, Q-I, X11(I+1,I), 1, TAUP1(I), - $ X11(I+1,I+1), LDX11, WORK(ILARF) ) + CALL SLARF1F( 'L', P-I, Q-I, X11(I+1,I), 1, TAUP1(I), + $ X11(I+1,I+1), LDX11, WORK(ILARF) ) END IF - X21(I,I) = ONE - CALL SLARF( 'L', M-P-I+1, Q-I, X21(I,I), 1, TAUP2(I), - $ X21(I,I+1), LDX21, WORK(ILARF) ) + CALL SLARF1F( 'L', M-P-I+1, Q-I, X21(I,I), 1, TAUP2(I), + $ X21(I,I+1), LDX21, WORK(ILARF) ) * END DO * @@ -319,9 +317,8 @@ SUBROUTINE SORBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, * DO I = P + 1, Q CALL SLARFGP( M-P-I+1, X21(I,I), X21(I+1,I), 1, TAUP2(I) ) - X21(I,I) = ONE - CALL SLARF( 'L', M-P-I+1, Q-I, X21(I,I), 1, TAUP2(I), - $ X21(I,I+1), LDX21, WORK(ILARF) ) + CALL SLARF1F( 'L', M-P-I+1, Q-I, X21(I,I), 1, TAUP2(I), + $ X21(I,I+1), LDX21, WORK(ILARF) ) END DO * RETURN diff --git a/SRC/sorbdb3.f b/SRC/sorbdb3.f index ba12eda1aa..d064723e6a 100644 --- a/SRC/sorbdb3.f +++ b/SRC/sorbdb3.f @@ -227,7 +227,7 @@ SUBROUTINE SORBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, LOGICAL LQUERY * .. * .. External Subroutines .. - EXTERNAL SLARF, SLARFGP, SORBDB5, SROT, + EXTERNAL SLARF1F, SLARFGP, SORBDB5, SROT, $ XERBLA * .. * .. External Functions .. @@ -288,11 +288,10 @@ SUBROUTINE SORBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, * CALL SLARFGP( Q-I+1, X21(I,I), X21(I,I+1), LDX21, TAUQ1(I) ) S = X21(I,I) - X21(I,I) = ONE - CALL SLARF( 'R', P-I+1, Q-I+1, X21(I,I), LDX21, TAUQ1(I), - $ X11(I,I), LDX11, WORK(ILARF) ) - CALL SLARF( 'R', M-P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I), - $ X21(I+1,I), LDX21, WORK(ILARF) ) + CALL SLARF1F( 'R', P-I+1, Q-I+1, X21(I,I), LDX21, TAUQ1(I), + $ X11(I,I), LDX11, WORK(ILARF) ) + CALL SLARF1F( 'R', M-P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I), + $ X21(I+1,I), LDX21, WORK(ILARF) ) C = SQRT( SNRM2( P-I+1, X11(I,I), 1 )**2 $ + SNRM2( M-P-I, X21(I+1,I), 1 )**2 ) THETA(I) = ATAN2( S, C ) @@ -307,14 +306,12 @@ SUBROUTINE SORBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI(I) = ATAN2( X21(I+1,I), X11(I,I) ) C = COS( PHI(I) ) S = SIN( PHI(I) ) - X21(I+1,I) = ONE - CALL SLARF( 'L', M-P-I, Q-I, X21(I+1,I), 1, TAUP2(I), - $ X21(I+1,I+1), LDX21, WORK(ILARF) ) + CALL SLARF1F( 'L', M-P-I, Q-I, X21(I+1,I), 1, TAUP2(I), + $ X21(I+1,I+1), LDX21, WORK(ILARF) ) END IF - X11(I,I) = ONE - CALL SLARF( 'L', P-I+1, Q-I, X11(I,I), 1, TAUP1(I), X11(I, - $ I+1), - $ LDX11, WORK(ILARF) ) + CALL SLARF1F( 'L', P-I+1, Q-I, X11(I,I), 1, TAUP1(I), X11(I, + $ I+1), + $ LDX11, WORK(ILARF) ) * END DO * @@ -322,10 +319,9 @@ SUBROUTINE SORBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, * DO I = M-P + 1, Q CALL SLARFGP( P-I+1, X11(I,I), X11(I+1,I), 1, TAUP1(I) ) - X11(I,I) = ONE - CALL SLARF( 'L', P-I+1, Q-I, X11(I,I), 1, TAUP1(I), X11(I, - $ I+1), - $ LDX11, WORK(ILARF) ) + CALL SLARF1F( 'L', P-I+1, Q-I, X11(I,I), 1, TAUP1(I), X11(I, + $ I+1), + $ LDX11, WORK(ILARF) ) END DO * RETURN diff --git a/SRC/sorbdb4.f b/SRC/sorbdb4.f index fc352c5555..0eb9edd658 100644 --- a/SRC/sorbdb4.f +++ b/SRC/sorbdb4.f @@ -239,7 +239,7 @@ SUBROUTINE SORBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, LOGICAL LQUERY * .. * .. External Subroutines .. - EXTERNAL SLARF, SLARFGP, SORBDB5, SROT, SSCAL, + EXTERNAL SLARF1F, SLARFGP, SORBDB5, SROT, SSCAL, $ XERBLA * .. * .. External Functions .. @@ -308,13 +308,12 @@ SUBROUTINE SORBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, THETA(I) = ATAN2( PHANTOM(1), PHANTOM(P+1) ) C = COS( THETA(I) ) S = SIN( THETA(I) ) - PHANTOM(1) = ONE - PHANTOM(P+1) = ONE - CALL SLARF( 'L', P, Q, PHANTOM(1), 1, TAUP1(1), X11, - $ LDX11, - $ WORK(ILARF) ) - CALL SLARF( 'L', M-P, Q, PHANTOM(P+1), 1, TAUP2(1), X21, - $ LDX21, WORK(ILARF) ) + CALL SLARF1F( 'L', P, Q, PHANTOM(1), 1, TAUP1(1), X11, + $ LDX11, + $ WORK(ILARF) ) + CALL SLARF1F( 'L', M-P, Q, PHANTOM(P+1), 1, TAUP2(1), + $ X21, + $ LDX21, WORK(ILARF) ) ELSE CALL SORBDB5( P-I+1, M-P-I+1, Q-I+1, X11(I,I-1), 1, $ X21(I,I-1), 1, X11(I,I), LDX11, X21(I,I), @@ -327,22 +326,20 @@ SUBROUTINE SORBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, THETA(I) = ATAN2( X11(I,I-1), X21(I,I-1) ) C = COS( THETA(I) ) S = SIN( THETA(I) ) - X11(I,I-1) = ONE - X21(I,I-1) = ONE - CALL SLARF( 'L', P-I+1, Q-I+1, X11(I,I-1), 1, TAUP1(I), - $ X11(I,I), LDX11, WORK(ILARF) ) - CALL SLARF( 'L', M-P-I+1, Q-I+1, X21(I,I-1), 1, TAUP2(I), - $ X21(I,I), LDX21, WORK(ILARF) ) + CALL SLARF1F( 'L', P-I+1, Q-I+1, X11(I,I-1), 1, TAUP1(I), + $ X11(I,I), LDX11, WORK(ILARF) ) + CALL SLARF1F( 'L', M-P-I+1, Q-I+1, X21(I,I-1), 1, + $ TAUP2(I), + $ X21(I,I), LDX21, WORK(ILARF) ) END IF * CALL SROT( Q-I+1, X11(I,I), LDX11, X21(I,I), LDX21, S, -C ) CALL SLARFGP( Q-I+1, X21(I,I), X21(I,I+1), LDX21, TAUQ1(I) ) C = X21(I,I) - X21(I,I) = ONE - CALL SLARF( 'R', P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I), - $ X11(I+1,I), LDX11, WORK(ILARF) ) - CALL SLARF( 'R', M-P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I), - $ X21(I+1,I), LDX21, WORK(ILARF) ) + CALL SLARF1F( 'R', P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I), + $ X11(I+1,I), LDX11, WORK(ILARF) ) + CALL SLARF1F( 'R', M-P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I), + $ X21(I+1,I), LDX21, WORK(ILARF) ) IF( I .LT. M-Q ) THEN S = SQRT( SNRM2( P-I, X11(I+1,I), 1 )**2 $ + SNRM2( M-P-I, X21(I+1,I), 1 )**2 ) @@ -355,11 +352,10 @@ SUBROUTINE SORBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, * DO I = M - Q + 1, P CALL SLARFGP( Q-I+1, X11(I,I), X11(I,I+1), LDX11, TAUQ1(I) ) - X11(I,I) = ONE - CALL SLARF( 'R', P-I, Q-I+1, X11(I,I), LDX11, TAUQ1(I), - $ X11(I+1,I), LDX11, WORK(ILARF) ) - CALL SLARF( 'R', Q-P, Q-I+1, X11(I,I), LDX11, TAUQ1(I), - $ X21(M-Q+1,I), LDX21, WORK(ILARF) ) + CALL SLARF1F( 'R', P-I, Q-I+1, X11(I,I), LDX11, TAUQ1(I), + $ X11(I+1,I), LDX11, WORK(ILARF) ) + CALL SLARF1F( 'R', Q-P, Q-I+1, X11(I,I), LDX11, TAUQ1(I), + $ X21(M-Q+1,I), LDX21, WORK(ILARF) ) END DO * * Reduce the bottom-right portion of X21 to [ 0 I ] @@ -368,10 +364,9 @@ SUBROUTINE SORBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, CALL SLARFGP( Q-I+1, X21(M-Q+I-P,I), X21(M-Q+I-P,I+1), $ LDX21, $ TAUQ1(I) ) - X21(M-Q+I-P,I) = ONE - CALL SLARF( 'R', Q-I, Q-I+1, X21(M-Q+I-P,I), LDX21, - $ TAUQ1(I), - $ X21(M-Q+I-P+1,I), LDX21, WORK(ILARF) ) + CALL SLARF1F( 'R', Q-I, Q-I+1, X21(M-Q+I-P,I), LDX21, + $ TAUQ1(I), + $ X21(M-Q+I-P+1,I), LDX21, WORK(ILARF) ) END DO * RETURN diff --git a/SRC/sorg2l.f b/SRC/sorg2l.f index 0a3c96697a..32bbbaabb9 100644 --- a/SRC/sorg2l.f +++ b/SRC/sorg2l.f @@ -133,7 +133,7 @@ SUBROUTINE SORG2L( M, N, K, A, LDA, TAU, WORK, INFO ) INTEGER I, II, J, L * .. * .. External Subroutines .. - EXTERNAL SLARF, SSCAL, XERBLA + EXTERNAL SLARF1L, SSCAL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX @@ -177,9 +177,9 @@ SUBROUTINE SORG2L( M, N, K, A, LDA, TAU, WORK, INFO ) * Apply H(i) to A(1:m-k+i,1:n-k+i) from the left * A( M-N+II, II ) = ONE - CALL SLARF( 'Left', M-N+II, II-1, A( 1, II ), 1, TAU( I ), - $ A, - $ LDA, WORK ) + CALL SLARF1L( 'Left', M-N+II, II-1, A( 1, II ), 1, TAU( I ), + $ A, + $ LDA, WORK ) CALL SSCAL( M-N+II-1, -TAU( I ), A( 1, II ), 1 ) A( M-N+II, II ) = ONE - TAU( I ) * diff --git a/SRC/sorg2r.f b/SRC/sorg2r.f index 67d35d950e..7c22013814 100644 --- a/SRC/sorg2r.f +++ b/SRC/sorg2r.f @@ -133,7 +133,7 @@ SUBROUTINE SORG2R( M, N, K, A, LDA, TAU, WORK, INFO ) INTEGER I, J, L * .. * .. External Subroutines .. - EXTERNAL SLARF, SSCAL, XERBLA + EXTERNAL SLARF1F, SSCAL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX @@ -176,9 +176,8 @@ SUBROUTINE SORG2R( M, N, K, A, LDA, TAU, WORK, INFO ) * Apply H(i) to A(i:m,i:n) from the left * IF( I.LT.N ) THEN - A( I, I ) = ONE - CALL SLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ), - $ A( I, I+1 ), LDA, WORK ) + CALL SLARF1F( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ), + $ A( I, I+1 ), LDA, WORK ) END IF IF( I.LT.M ) $ CALL SSCAL( M-I, -TAU( I ), A( I+1, I ), 1 ) diff --git a/SRC/sorgl2.f b/SRC/sorgl2.f index 2f03d32e53..0ea0ed9714 100644 --- a/SRC/sorgl2.f +++ b/SRC/sorgl2.f @@ -132,7 +132,7 @@ SUBROUTINE SORGL2( M, N, K, A, LDA, TAU, WORK, INFO ) INTEGER I, J, L * .. * .. External Subroutines .. - EXTERNAL SLARF, SSCAL, XERBLA + EXTERNAL SLARF1F, SSCAL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX @@ -180,9 +180,8 @@ SUBROUTINE SORGL2( M, N, K, A, LDA, TAU, WORK, INFO ) * IF( I.LT.N ) THEN IF( I.LT.M ) THEN - A( I, I ) = ONE - CALL SLARF( 'Right', M-I, N-I+1, A( I, I ), LDA, - $ TAU( I ), A( I+1, I ), LDA, WORK ) + CALL SLARF1F( 'Right', M-I, N-I+1, A( I, I ), LDA, + $ TAU( I ), A( I+1, I ), LDA, WORK ) END IF CALL SSCAL( N-I, -TAU( I ), A( I, I+1 ), LDA ) END IF diff --git a/SRC/sorgr2.f b/SRC/sorgr2.f index 73caec659a..3435d3586f 100644 --- a/SRC/sorgr2.f +++ b/SRC/sorgr2.f @@ -133,7 +133,7 @@ SUBROUTINE SORGR2( M, N, K, A, LDA, TAU, WORK, INFO ) INTEGER I, II, J, L * .. * .. External Subroutines .. - EXTERNAL SLARF, SSCAL, XERBLA + EXTERNAL SLARF1L, SSCAL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX @@ -181,9 +181,9 @@ SUBROUTINE SORGR2( M, N, K, A, LDA, TAU, WORK, INFO ) * Apply H(i) to A(1:m-k+i,1:n-k+i) from the right * A( II, N-M+II ) = ONE - CALL SLARF( 'Right', II-1, N-M+II, A( II, 1 ), LDA, - $ TAU( I ), - $ A, LDA, WORK ) + CALL SLARF1L( 'Right', II-1, N-M+II, A( II, 1 ), LDA, + $ TAU( I ), + $ A, LDA, WORK ) CALL SSCAL( N-M+II-1, -TAU( I ), A( II, 1 ), LDA ) A( II, N-M+II ) = ONE - TAU( I ) * diff --git a/SRC/sorml2.f b/SRC/sorml2.f index 27f970fcdb..7ebd0caf8a 100644 --- a/SRC/sorml2.f +++ b/SRC/sorml2.f @@ -178,14 +178,13 @@ SUBROUTINE SORML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, * .. Local Scalars .. LOGICAL LEFT, NOTRAN INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ - REAL AII * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. - EXTERNAL SLARF, XERBLA + EXTERNAL SLARF1F, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX @@ -266,11 +265,8 @@ SUBROUTINE SORML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, * * Apply H(i) * - AII = A( I, I ) - A( I, I ) = ONE - CALL SLARF( SIDE, MI, NI, A( I, I ), LDA, TAU( I ), - $ C( IC, JC ), LDC, WORK ) - A( I, I ) = AII + CALL SLARF1F( SIDE, MI, NI, A( I, I ), LDA, TAU( I ), + $ C( IC, JC ), LDC, WORK ) 10 CONTINUE RETURN * diff --git a/SRC/sormr2.f b/SRC/sormr2.f index 5e71a483aa..e0e4f73311 100644 --- a/SRC/sormr2.f +++ b/SRC/sormr2.f @@ -178,14 +178,13 @@ SUBROUTINE SORMR2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, * .. Local Scalars .. LOGICAL LEFT, NOTRAN INTEGER I, I1, I2, I3, MI, NI, NQ - REAL AII * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. - EXTERNAL SLARF, XERBLA + EXTERNAL SLARF1L, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX @@ -262,11 +261,9 @@ SUBROUTINE SORMR2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, * * Apply H(i) * - AII = A( I, NQ-K+I ) - A( I, NQ-K+I ) = ONE - CALL SLARF( SIDE, MI, NI, A( I, 1 ), LDA, TAU( I ), C, LDC, - $ WORK ) - A( I, NQ-K+I ) = AII + CALL SLARF1L( SIDE, MI, NI, A( I, 1 ), LDA, TAU( I ), C, + $ LDC, + $ WORK ) 10 CONTINUE RETURN * From 6c0a98f8c4097b3fb86e9069b8b1ac01574f59fa Mon Sep 17 00:00:00 2001 From: Eduard Fedorenkov Date: Wed, 5 Jun 2024 17:50:09 +0700 Subject: [PATCH 06/16] implement clarf1f, #1011 --- SRC/CMakeLists.txt | 2 +- SRC/Makefile | 2 +- SRC/clarf1f.f | 267 +++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 269 insertions(+), 2 deletions(-) create mode 100644 SRC/clarf1f.f diff --git a/SRC/CMakeLists.txt b/SRC/CMakeLists.txt index ba83a6bcb0..fe7670e146 100644 --- a/SRC/CMakeLists.txt +++ b/SRC/CMakeLists.txt @@ -218,7 +218,7 @@ set(CLASRC 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 claqsp.f claqsy.f clar1v.f clar2v.f ilaclr.f ilaclc.f - clarf.f clarfb.f clarfb_gett.f clarfg.f clarfgp.f clarft.f + clarf.f clarf1f.f clarfb.f clarfb_gett.f clarfg.f clarfgp.f clarft.f clarfx.f clarfy.f clargv.f clarnv.f clarrv.f clartg.f90 clartv.f clarz.f clarzb.f clarzt.f clascl.f claset.f clasr.f classq.f90 claswp.f clasyf.f clasyf_rook.f clasyf_rk.f clasyf_aa.f diff --git a/SRC/Makefile b/SRC/Makefile index 4c3867f686..6fbebc544d 100644 --- a/SRC/Makefile +++ b/SRC/Makefile @@ -249,7 +249,7 @@ CLASRC = \ claqhb.o claqhe.o claqhp.o claqp2.o claqps.o claqp2rk.o claqp3rk.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 \ - clarf.o clarfb.o clarfb_gett.o clarfg.o clarft.o clarfgp.o \ + clarf.o clarf1f.o clarfb.o clarfb_gett.o clarfg.o clarft.o clarfgp.o \ clarfx.o clarfy.o clargv.o clarnv.o clarrv.o clartg.o clartv.o \ clarz.o clarzb.o clarzt.o clascl.o claset.o clasr.o classq.o \ claswp.o clasyf.o clasyf_rook.o clasyf_rk.o clasyf_aa.o \ diff --git a/SRC/clarf1f.f b/SRC/clarf1f.f new file mode 100644 index 0000000000..b1cc9e9792 --- /dev/null +++ b/SRC/clarf1f.f @@ -0,0 +1,267 @@ +*> \brief \b CLARF1F applies an elementary reflector to a general rectangular +* matrix assuming v(1) = 1. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download CLARF1F + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE CLARF1F( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) +* +* .. Scalar Arguments .. +* CHARACTER SIDE +* INTEGER INCV, LDC, M, N +* COMPLEX TAU +* .. +* .. Array Arguments .. +* COMPLEX C( LDC, * ), V( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CLARF1F applies a complex elementary reflector H to a complex m by n matrix +*> C, from either the left or the right. H is represented in the form +*> +*> H = I - tau * v * v**H +*> +*> where tau is a complex scalar and v is a complex vector assuming v(1) = 1. +*> +*> If tau = 0, then H is taken to be the unit matrix. +*> +*> To apply H**H (the conjugate transpose of H), supply conjg(tau) instead +*> tau. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> = 'L': form H * C +*> = 'R': form C * H +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix C. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix C. +*> \endverbatim +*> +*> \param[in] V +*> \verbatim +*> V is COMPLEX array, dimension +*> (1 + (M-1)*abs(INCV)) if SIDE = 'L' +*> or (1 + (N-1)*abs(INCV)) if SIDE = 'R' +*> The vector v in the representation of H. V is not used if +*> TAU = 0. +*> \endverbatim +*> +*> \param[in] INCV +*> \verbatim +*> INCV is INTEGER +*> The increment between elements of v. INCV <> 0. +*> \endverbatim +*> +*> \param[in] TAU +*> \verbatim +*> TAU is COMPLEX +*> The value tau in the representation of H. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is COMPLEX array, dimension (LDC,N) +*> On entry, the m by n matrix C. +*> On exit, C is overwritten by the matrix H * C if SIDE = 'L', +*> or C * H if SIDE = 'R'. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,M). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX array, dimension +*> (N) if SIDE = 'L' +*> or (M) if SIDE = 'R' +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup larf1f +* +* ===================================================================== + SUBROUTINE CLARF1F( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) +* +* -- LAPACK auxiliary routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER SIDE + INTEGER INCV, LDC, M, N + COMPLEX TAU +* .. +* .. Array Arguments .. + COMPLEX C( LDC, * ), V( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX ONE, ZERO + PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ), + $ ZERO = ( 0.0E+0, 0.0E+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL APPLYLEFT + INTEGER I, LASTV, LASTC +* .. +* .. External Subroutines .. + EXTERNAL CGEMV, CGER, CSCAL +* .. +* .. Intrinsic Functions .. + INTRINSIC CONJG +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILACLR, ILACLC + EXTERNAL LSAME, ILACLR, ILACLC +* .. +* .. Executable Statements .. +* + APPLYLEFT = LSAME( SIDE, 'L' ) + LASTV = 0 + LASTC = 0 + IF( TAU.NE.ZERO ) THEN +! Set up variables for scanning V. LASTV begins pointing to the end +! of V. + IF( APPLYLEFT ) THEN + LASTV = M + ELSE + LASTV = N + END IF + IF( INCV.GT.0 ) THEN + I = 1 + (LASTV-1) * INCV + ELSE + I = 1 + END IF +! Look for the last non-zero row in V. + DO WHILE( LASTV.GT.0 .AND. V( I ).EQ.ZERO ) + LASTV = LASTV - 1 + I = I - INCV + END DO + IF( APPLYLEFT ) THEN +! Scan for the last non-zero column in C(1:lastv,:). + LASTC = ILACLC(LASTV, N, C, LDC) + ELSE +! Scan for the last non-zero row in C(:,1:lastv). + LASTC = ILACLR(M, LASTV, C, LDC) + END IF + END IF + IF( LASTC.EQ.0 .OR. LASTV.EQ.0 ) THEN + RETURN + END IF + IF( APPLYLEFT ) THEN +* +* Form H * C +* + IF( LASTV.EQ.1 ) THEN +* +* C(1,1:lastc) := ( 1 - tau ) * C(1,1:lastc) +* + CALL CSCAL( LASTC, ONE - TAU, C, LDC ) + ELSE +* +* w(1:lastc,1) := C(2:lastv,1:lastc)**H * v(2:lastv,1) +* + CALL CGEMV( 'Conjugate transpose', LASTV - 1, LASTC, ONE, + $ C( 2, 1 ), LDC, V( 1 + INCV ), INCV, ZERO, + $ WORK, 1 ) +* +* w(1:lastc,1) += v(1,1) * C(1,1:lastc)**H +* + DO I = 1, LASTC + WORK( I ) = WORK( I ) + CONJG( C( 1, I ) ) + END DO +* +* C(1, 1:lastc) += - tau * v(1,1) * w(1:lastc,1)**H +* + DO I = 1, LASTC + C( 1, I ) = C( 1, I ) - TAU * CONJG( WORK( I ) ) + END DO +* +* C(2:lastv,1:lastc) += - tau * v(2:lastv,1) * w(1:lastc,1)**H +* + CALL CGERC( LASTV - 1, LASTC, -TAU, V( 1 + INCV ), INCV, + $ WORK, 1, C( 2, 1 ), LDC ) + END IF + ELSE +* +* Form C * H +* + IF( LASTV.EQ.1 ) THEN +* +* C(1:lastc,1) := ( 1 - tau ) * C(1:lastc,1) +* + CALL CSCAL( LASTC, ONE - TAU, C, 1 ) + ELSE +* +* w(1:lastc,1) := C(1:lastc,2:lastv) * v(2:lastv,1) +* + CALL CGEMV( 'No transpose', LASTC, LASTV - 1, ONE, + $ C( 1, 2 ), LDC, V( 1 + INCV ), INCV, ZERO, + $ WORK, 1 ) +* +* w(1:lastc,1) += v(1,1) * C(1:lastc,1) +* + CALL CAXPY( LASTC, ONE, C, 1, WORK, 1 ) +* +* C(1:lastc,1) += - tau * v(1,1) * w(1:lastc,1) +* + CALL CAXPY( LASTC, -TAU, WORK, 1, C, 1 ) +* +* C(1:lastc,2:lastv) += - tau * w(1:lastc,1) * v(2:lastv)**H +* + CALL CGERC( LASTC, LASTV - 1, -TAU, WORK, 1, + $ V( 1 + INCV ), INCV, C( 1, 2 ), LDC ) + END IF + END IF + RETURN +* +* End of CLARF1F +* + END From 5889e3e22fb236b720f43882f070f766ea8f2520 Mon Sep 17 00:00:00 2001 From: Eduard Fedorenkov Date: Wed, 5 Jun 2024 17:54:22 +0700 Subject: [PATCH 07/16] try clarf1f in cunm2r, #1011 --- SRC/cunm2r.f | 12 +++++------- 1 file changed, 5 insertions(+), 7 deletions(-) diff --git a/SRC/cunm2r.f b/SRC/cunm2r.f index 0682381be3..094a15bf7c 100644 --- a/SRC/cunm2r.f +++ b/SRC/cunm2r.f @@ -178,14 +178,14 @@ SUBROUTINE CUNM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, * .. Local Scalars .. LOGICAL LEFT, NOTRAN INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ - COMPLEX AII, TAUI + COMPLEX TAUI * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. - EXTERNAL CLARF, XERBLA + EXTERNAL CLARF1F, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC CONJG, MAX @@ -270,12 +270,10 @@ SUBROUTINE CUNM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, ELSE TAUI = CONJG( TAU( I ) ) END IF - AII = A( I, I ) A( I, I ) = ONE - CALL CLARF( SIDE, MI, NI, A( I, I ), 1, TAUI, C( IC, JC ), - $ LDC, - $ WORK ) - A( I, I ) = AII + CALL CLARF1F( SIDE, MI, NI, A( I, I ), 1, TAUI, C( IC, JC ), + $ LDC, + $ WORK ) 10 CONTINUE RETURN * From 1d4010e26ad84a71cbf855fab297ecf509bf3567 Mon Sep 17 00:00:00 2001 From: Eduard Fedorenkov Date: Thu, 6 Jun 2024 15:01:52 +0700 Subject: [PATCH 08/16] fix lastv possible range in slarf1f and slarf1l, #1011 --- SRC/slarf1f.f | 8 ++++---- SRC/slarf1l.f | 8 ++++---- 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/SRC/slarf1f.f b/SRC/slarf1f.f index 493e57bb21..daf43423f5 100644 --- a/SRC/slarf1f.f +++ b/SRC/slarf1f.f @@ -157,11 +157,11 @@ SUBROUTINE SLARF1F( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) * .. Executable Statements .. * APPLYLEFT = LSAME( SIDE, 'L' ) - LASTV = 0 + LASTV = 1 LASTC = 0 IF( TAU.NE.ZERO ) THEN ! Set up variables for scanning V. LASTV begins pointing to the end -! of V. +! of V up to V(1). IF( APPLYLEFT ) THEN LASTV = M ELSE @@ -173,7 +173,7 @@ SUBROUTINE SLARF1F( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) I = 1 END IF ! Look for the last non-zero row in V. - DO WHILE( LASTV.GT.0 .AND. V( I ).EQ.ZERO ) + DO WHILE( LASTV.GT.1 .AND. V( I ).EQ.ZERO ) LASTV = LASTV - 1 I = I - INCV END DO @@ -185,7 +185,7 @@ SUBROUTINE SLARF1F( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) LASTC = ILASLR(M, LASTV, C, LDC) END IF END IF - IF( LASTC.EQ.0 .OR. LASTV.EQ.0 ) THEN + IF( LASTC.EQ.0 ) THEN RETURN END IF IF( APPLYLEFT ) THEN diff --git a/SRC/slarf1l.f b/SRC/slarf1l.f index 901b01dce2..d7b0eb759b 100644 --- a/SRC/slarf1l.f +++ b/SRC/slarf1l.f @@ -159,11 +159,11 @@ SUBROUTINE SLARF1L( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) * .. Executable Statements .. * APPLYLEFT = LSAME( SIDE, 'L' ) - LASTV = 0 + LASTV = 1 LASTC = 0 IF( TAU.NE.ZERO ) THEN ! Set up variables for scanning V. LASTV begins pointing to the end -! of V. +! of V up to V(1). IF( APPLYLEFT ) THEN LASTV = M ELSE @@ -175,7 +175,7 @@ SUBROUTINE SLARF1L( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) I = 1 END IF ! Look for the last non-zero row in V. - DO WHILE( LASTV.GT.0 .AND. V( I ).EQ.ZERO ) + DO WHILE( LASTV.GT.1 .AND. V( I ).EQ.ZERO ) LASTV = LASTV - 1 I = I - INCV END DO @@ -187,7 +187,7 @@ SUBROUTINE SLARF1L( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) LASTC = ILASLR(M, LASTV, C, LDC) END IF END IF - IF( LASTC.EQ.0 .OR. LASTV.EQ.0 ) THEN + IF( LASTC.EQ.0 ) THEN RETURN END IF IF( APPLYLEFT ) THEN From ea943fc1c70093ffe6927dafa9e74d3d01809d0d Mon Sep 17 00:00:00 2001 From: Eduard Fedorenkov Date: Thu, 6 Jun 2024 16:35:50 +0700 Subject: [PATCH 09/16] fix lastv possible range in clarf1f, #1011 --- SRC/clarf1f.f | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/SRC/clarf1f.f b/SRC/clarf1f.f index b1cc9e9792..255f074e4f 100644 --- a/SRC/clarf1f.f +++ b/SRC/clarf1f.f @@ -164,11 +164,11 @@ SUBROUTINE CLARF1F( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) * .. Executable Statements .. * APPLYLEFT = LSAME( SIDE, 'L' ) - LASTV = 0 + LASTV = 1 LASTC = 0 IF( TAU.NE.ZERO ) THEN ! Set up variables for scanning V. LASTV begins pointing to the end -! of V. +! of V up to V(1). IF( APPLYLEFT ) THEN LASTV = M ELSE @@ -180,7 +180,7 @@ SUBROUTINE CLARF1F( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) I = 1 END IF ! Look for the last non-zero row in V. - DO WHILE( LASTV.GT.0 .AND. V( I ).EQ.ZERO ) + DO WHILE( LASTV.GT.1 .AND. V( I ).EQ.ZERO ) LASTV = LASTV - 1 I = I - INCV END DO @@ -192,7 +192,7 @@ SUBROUTINE CLARF1F( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) LASTC = ILACLR(M, LASTV, C, LDC) END IF END IF - IF( LASTC.EQ.0 .OR. LASTV.EQ.0 ) THEN + IF( LASTC.EQ.0 ) THEN RETURN END IF IF( APPLYLEFT ) THEN From b8b97714c342f92872f2f3025d3322ced964d1bc Mon Sep 17 00:00:00 2001 From: Eduard Fedorenkov Date: Thu, 6 Jun 2024 16:36:51 +0700 Subject: [PATCH 10/16] implement clarf1l, #1011 --- SRC/CMakeLists.txt | 2 +- SRC/Makefile | 2 +- SRC/clarf1l.f | 267 +++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 269 insertions(+), 2 deletions(-) create mode 100644 SRC/clarf1l.f diff --git a/SRC/CMakeLists.txt b/SRC/CMakeLists.txt index fe7670e146..d9662db944 100644 --- a/SRC/CMakeLists.txt +++ b/SRC/CMakeLists.txt @@ -218,7 +218,7 @@ set(CLASRC 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 claqsp.f claqsy.f clar1v.f clar2v.f ilaclr.f ilaclc.f - clarf.f clarf1f.f clarfb.f clarfb_gett.f clarfg.f clarfgp.f clarft.f + clarf.f clarf1f.f clarf1l.f clarfb.f clarfb_gett.f clarfg.f clarfgp.f clarft.f clarfx.f clarfy.f clargv.f clarnv.f clarrv.f clartg.f90 clartv.f clarz.f clarzb.f clarzt.f clascl.f claset.f clasr.f classq.f90 claswp.f clasyf.f clasyf_rook.f clasyf_rk.f clasyf_aa.f diff --git a/SRC/Makefile b/SRC/Makefile index 6fbebc544d..7fb2a5670d 100644 --- a/SRC/Makefile +++ b/SRC/Makefile @@ -249,7 +249,7 @@ CLASRC = \ claqhb.o claqhe.o claqhp.o claqp2.o claqps.o claqp2rk.o claqp3rk.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 \ - clarf.o clarf1f.o clarfb.o clarfb_gett.o clarfg.o clarft.o clarfgp.o \ + clarf.o clarf1f.o clarf1l.o clarfb.o clarfb_gett.o clarfg.o clarft.o clarfgp.o \ clarfx.o clarfy.o clargv.o clarnv.o clarrv.o clartg.o clartv.o \ clarz.o clarzb.o clarzt.o clascl.o claset.o clasr.o classq.o \ claswp.o clasyf.o clasyf_rook.o clasyf_rk.o clasyf_aa.o \ diff --git a/SRC/clarf1l.f b/SRC/clarf1l.f new file mode 100644 index 0000000000..40dda403a7 --- /dev/null +++ b/SRC/clarf1l.f @@ -0,0 +1,267 @@ +*> \brief \b CLARF1L applies an elementary reflector to a general rectangular +* matrix assuming v(lastv) = 1, where lastv is the last non-zero +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download CLARF1L + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE CLARF1L( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) +* +* .. Scalar Arguments .. +* CHARACTER SIDE +* INTEGER INCV, LDC, M, N +* COMPLEX TAU +* .. +* .. Array Arguments .. +* COMPLEX C( LDC, * ), V( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CLARF1L applies a complex elementary reflector H to a complex m by n matrix +*> C, from either the left or the right. H is represented in the form +*> +*> H = I - tau * v * v**H +*> +*> where tau is a real scalar and v is a real vector assuming v(lastv) = 1, +*> where lastv is the last non-zero element. +*> +*> If tau = 0, then H is taken to be the unit matrix. +*> +*> To apply H**H (the conjugate transpose of H), supply conjg(tau) instead +*> tau. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> = 'L': form H * C +*> = 'R': form C * H +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix C. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix C. +*> \endverbatim +*> +*> \param[in] V +*> \verbatim +*> V is COMPLEX array, dimension +*> (1 + (M-1)*abs(INCV)) if SIDE = 'L' +*> or (1 + (N-1)*abs(INCV)) if SIDE = 'R' +*> The vector v in the representation of H. V is not used if +*> TAU = 0. +*> \endverbatim +*> +*> \param[in] INCV +*> \verbatim +*> INCV is INTEGER +*> The increment between elements of v. INCV <> 0. +*> \endverbatim +*> +*> \param[in] TAU +*> \verbatim +*> TAU is COMPLEX +*> The value tau in the representation of H. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is COMPLEX array, dimension (LDC,N) +*> On entry, the m by n matrix C. +*> On exit, C is overwritten by the matrix H * C if SIDE = 'L', +*> or C * H if SIDE = 'R'. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,M). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX array, dimension +*> (N) if SIDE = 'L' +*> or (M) if SIDE = 'R' +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup larf1f +* +* ===================================================================== + SUBROUTINE CLARF1L( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) +* +* -- LAPACK auxiliary routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER SIDE + INTEGER INCV, LDC, M, N + COMPLEX TAU +* .. +* .. Array Arguments .. + COMPLEX C( LDC, * ), V( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX ONE, ZERO + PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ), + $ ZERO = ( 0.0E+0, 0.0E+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL APPLYLEFT + INTEGER I, LASTV, LASTC +* .. +* .. External Subroutines .. + EXTERNAL CGEMV, CGERC, CSCAL +* .. +* .. Intrinsic Functions .. + INTRINSIC CONJG +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILACLR, ILACLC + EXTERNAL LSAME, ILACLR, ILACLC +* .. +* .. Executable Statements .. +* + APPLYLEFT = LSAME( SIDE, 'L' ) + LASTV = 1 + LASTC = 0 + IF( TAU.NE.ZERO ) THEN +! Set up variables for scanning V. LASTV begins pointing to the end +! of V up to V(1). + IF( APPLYLEFT ) THEN + LASTV = M + ELSE + LASTV = N + END IF + IF( INCV.GT.0 ) THEN + I = 1 + (LASTV-1) * INCV + ELSE + I = 1 + END IF +! Look for the last non-zero row in V. + DO WHILE( LASTV.GT.1 .AND. V( I ).EQ.ZERO ) + LASTV = LASTV - 1 + I = I - INCV + END DO + IF( APPLYLEFT ) THEN +! Scan for the last non-zero column in C(1:lastv,:). + LASTC = ILACLC(LASTV, N, C, LDC) + ELSE +! Scan for the last non-zero row in C(:,1:lastv). + LASTC = ILACLR(M, LASTV, C, LDC) + END IF + END IF + IF( LASTC.EQ.0 ) THEN + RETURN + END IF + IF( APPLYLEFT ) THEN +* +* Form H * C +* + IF( LASTV.EQ.1 ) THEN +* +* C(1,1:lastc) := ( 1 - tau ) * C(1,1:lastc) +* + CALL CSCAL( LASTC, ONE - TAU, C, LDC ) + ELSE +* +* w(1:lastc,1) := C(1:lastv-1,1:lastc)**T * v(1:lastv-1,1) +* + CALL CGEMV( 'Conjugate transpose', LASTV - 1, LASTC, + $ ONE, C, LDC, V, INCV, ZERO, WORK, 1 ) +* +* w(1:lastc,1) += C(lastv,1:lastc)**H * v(lastv,1) +* + DO I = 1, LASTC + WORK( I ) = WORK( I ) + CONJG( C( LASTV, I ) ) + END DO +* +* C(lastv,1:lastc) += - tau * v(lastv,1) * w(1:lastc,1)**H +* + DO I = 1, LASTC + C( LASTV, I ) = C( LASTV, I ) + $ - TAU * CONJG( WORK( I ) ) + END DO +* +* C(1:lastv-1,1:lastc) += - tau * v(1:lastv-1,1) * w(1:lastc,1)**H +* + CALL CGERC( LASTV - 1, LASTC, -TAU, V, INCV, WORK, 1, C, + $ LDC) + END IF + ELSE +* +* Form C * H +* + IF( LASTV.EQ.1 ) THEN +* +* C(1:lastc,1) := ( 1 - tau ) * C(1:lastc,1) +* + CALL CSCAL( LASTC, ONE - TAU, C, 1 ) + ELSE +* +* w(1:lastc,1) := C(1:lastc,1:lastv-1) * v(1:lastv-1,1) +* + CALL CGEMV( 'No transpose', LASTC, LASTV - 1, ONE, C, + $ LDC, V, INCV, ZERO, WORK, 1 ) +* +* w(1:lastc,1) += C(1:lastc,lastv) * v(lastv,1) +* + CALL CAXPY( LASTC, ONE, C( 1, LASTV ), 1, WORK, 1 ) +* +* C(1:lastc,lastv) += - tau * v(lastv,1) * w(1:lastc,1) +* + CALL CAXPY( LASTC, -TAU, WORK, 1, C( 1, LASTV ), 1 ) +* +* C(1:lastc,1:lastv-1) += - tau * w(1:lastc,1) * v(1:lastv-1)**H +* + CALL CGERC( LASTC, LASTV - 1, -TAU, WORK, 1, V, + $ INCV, C, LDC ) + END IF + END IF + RETURN +* +* End of CLARF1L +* + END From 8ed1ab507fc0aa466dc363e47a3520380e52a545 Mon Sep 17 00:00:00 2001 From: Eduard Fedorenkov Date: Fri, 7 Jun 2024 14:30:34 +0700 Subject: [PATCH 11/16] update single complex routines to use clarf1f and clarf1l, #1011 --- SRC/cgebd2.f | 30 +++++------- SRC/cgehd2.f | 20 +++----- SRC/cgelq2.f | 18 ++----- SRC/cgeql2.f | 17 ++----- SRC/cgeqp3rk.f | 4 +- SRC/cgeqr2.f | 14 ++---- SRC/cgeqr2p.f | 14 ++---- SRC/cgerq2.f | 16 ++----- SRC/claqp2.f | 16 ++----- SRC/claqp2rk.f | 19 +++----- SRC/claqr2.f | 20 ++++---- SRC/claqr3.f | 20 ++++---- SRC/cunbdb.f | 127 +++++++++++++++++++++++-------------------------- SRC/cunbdb1.f | 27 +++++------ SRC/cunbdb2.f | 35 +++++++------- SRC/cunbdb3.f | 32 +++++-------- SRC/cunbdb4.f | 57 ++++++++++------------ SRC/cung2l.f | 8 ++-- SRC/cung2r.f | 7 ++- SRC/cungl2.f | 8 ++-- SRC/cungr2.f | 6 +-- SRC/cunm2l.f | 14 ++---- SRC/cunm2r.f | 5 -- SRC/cunml2.f | 15 ++---- SRC/cunmr2.f | 15 ++---- SRC/cupmtr.f | 22 +++------ 26 files changed, 228 insertions(+), 358 deletions(-) diff --git a/SRC/cgebd2.f b/SRC/cgebd2.f index 5175d9e845..b4e3e6dd0c 100644 --- a/SRC/cgebd2.f +++ b/SRC/cgebd2.f @@ -203,16 +203,15 @@ SUBROUTINE CGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO ) * ===================================================================== * * .. Parameters .. - COMPLEX ZERO, ONE - PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ), - $ ONE = ( 1.0E+0, 0.0E+0 ) ) + COMPLEX ZERO + PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) ) * .. * .. Local Scalars .. INTEGER I COMPLEX ALPHA * .. * .. External Subroutines .. - EXTERNAL CLACGV, CLARF, CLARFG, XERBLA + EXTERNAL CLACGV, CLARF1F, CLARFG, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC CONJG, MAX, MIN @@ -246,13 +245,13 @@ SUBROUTINE CGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO ) CALL CLARFG( M-I+1, ALPHA, A( MIN( I+1, M ), I ), 1, $ TAUQ( I ) ) D( I ) = REAL( ALPHA ) - A( I, I ) = ONE * * Apply H(i)**H to A(i:m,i+1:n) from the left * IF( I.LT.N ) - $ CALL CLARF( 'Left', M-I+1, N-I, A( I, I ), 1, - $ CONJG( TAUQ( I ) ), A( I, I+1 ), LDA, WORK ) + $ CALL CLARF1F( 'Left', M-I+1, N-I, A( I, I ), 1, + $ CONJG( TAUQ( I ) ), A( I, I+1 ), LDA, + $ WORK ) A( I, I ) = D( I ) * IF( I.LT.N ) THEN @@ -265,12 +264,11 @@ SUBROUTINE CGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO ) CALL CLARFG( N-I, ALPHA, A( I, MIN( I+2, N ) ), $ LDA, TAUP( I ) ) E( I ) = REAL( ALPHA ) - A( I, I+1 ) = ONE * * Apply G(i) to A(i+1:m,i+1:n) from the right * - CALL CLARF( 'Right', M-I, N-I, A( I, I+1 ), LDA, - $ TAUP( I ), A( I+1, I+1 ), LDA, WORK ) + CALL CLARF1F( 'Right', M-I, N-I, A( I, I+1 ), LDA, + $ TAUP( I ), A( I+1, I+1 ), LDA, WORK ) CALL CLACGV( N-I, A( I, I+1 ), LDA ) A( I, I+1 ) = E( I ) ELSE @@ -290,13 +288,12 @@ SUBROUTINE CGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO ) CALL CLARFG( N-I+1, ALPHA, A( I, MIN( I+1, N ) ), LDA, $ TAUP( I ) ) D( I ) = REAL( ALPHA ) - A( I, I ) = ONE * * Apply G(i) to A(i+1:m,i:n) from the right * IF( I.LT.M ) - $ CALL CLARF( 'Right', M-I, N-I+1, A( I, I ), LDA, - $ TAUP( I ), A( I+1, I ), LDA, WORK ) + $ CALL CLARF1F( 'Right', M-I, N-I+1, A( I, I ), LDA, + $ TAUP( I ), A( I+1, I ), LDA, WORK ) CALL CLACGV( N-I+1, A( I, I ), LDA ) A( I, I ) = D( I ) * @@ -309,13 +306,12 @@ SUBROUTINE CGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO ) CALL CLARFG( M-I, ALPHA, A( MIN( I+2, M ), I ), 1, $ TAUQ( I ) ) E( I ) = REAL( ALPHA ) - A( I+1, I ) = ONE * * Apply H(i)**H to A(i+1:m,i+1:n) from the left * - CALL CLARF( 'Left', M-I, N-I, A( I+1, I ), 1, - $ CONJG( TAUQ( I ) ), A( I+1, I+1 ), LDA, - $ WORK ) + CALL CLARF1F( 'Left', M-I, N-I, A( I+1, I ), 1, + $ CONJG( TAUQ( I ) ), A( I+1, I+1 ), LDA, + $ WORK ) A( I+1, I ) = E( I ) ELSE TAUQ( I ) = ZERO diff --git a/SRC/cgehd2.f b/SRC/cgehd2.f index 2502d38b9a..808aa236bd 100644 --- a/SRC/cgehd2.f +++ b/SRC/cgehd2.f @@ -160,16 +160,11 @@ SUBROUTINE CGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO ) * * ===================================================================== * -* .. Parameters .. - COMPLEX ONE - PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ) ) -* .. * .. Local Scalars .. INTEGER I - COMPLEX ALPHA * .. * .. External Subroutines .. - EXTERNAL CLARF, CLARFG, XERBLA + EXTERNAL CLARF1F, CLARFG, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC CONJG, MAX, MIN @@ -197,22 +192,19 @@ SUBROUTINE CGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO ) * * Compute elementary reflector H(i) to annihilate A(i+2:ihi,i) * - ALPHA = A( I+1, I ) - CALL CLARFG( IHI-I, ALPHA, A( MIN( I+2, N ), I ), 1, + CALL CLARFG( IHI-I, A( I+1, I ), A( MIN( I+2, N ), I ), 1, $ TAU( I ) ) - A( I+1, I ) = ONE * * Apply H(i) to A(1:ihi,i+1:ihi) from the right * - CALL CLARF( 'Right', IHI, IHI-I, A( I+1, I ), 1, TAU( I ), - $ A( 1, I+1 ), LDA, WORK ) + CALL CLARF1F( 'Right', IHI, IHI-I, A( I+1, I ), 1, TAU( I ), + $ A( 1, I+1 ), LDA, WORK ) * * Apply H(i)**H to A(i+1:ihi,i+1:n) from the left * - CALL CLARF( 'Left', IHI-I, N-I, A( I+1, I ), 1, - $ CONJG( TAU( I ) ), A( I+1, I+1 ), LDA, WORK ) + CALL CLARF1F( 'Left', IHI-I, N-I, A( I+1, I ), 1, + $ CONJG( TAU( I ) ), A( I+1, I+1 ), LDA, WORK ) * - A( I+1, I ) = ALPHA 10 CONTINUE * RETURN diff --git a/SRC/cgelq2.f b/SRC/cgelq2.f index bf7d669a13..80f056e9be 100644 --- a/SRC/cgelq2.f +++ b/SRC/cgelq2.f @@ -140,16 +140,11 @@ SUBROUTINE CGELQ2( M, N, A, LDA, TAU, WORK, INFO ) * * ===================================================================== * -* .. Parameters .. - COMPLEX ONE - PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ) ) -* .. * .. Local Scalars .. INTEGER I, K - COMPLEX ALPHA * .. * .. External Subroutines .. - EXTERNAL CLACGV, CLARF, CLARFG, XERBLA + EXTERNAL CLACGV, CLARF1F, CLARFG, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN @@ -178,19 +173,16 @@ SUBROUTINE CGELQ2( M, N, A, LDA, TAU, WORK, INFO ) * Generate elementary reflector H(i) to annihilate A(i,i+1:n) * CALL CLACGV( N-I+1, A( I, I ), LDA ) - ALPHA = A( I, I ) - CALL CLARFG( N-I+1, ALPHA, A( I, MIN( I+1, N ) ), LDA, + CALL CLARFG( N-I+1, A( I, I ), A( I, MIN( I+1, N ) ), LDA, $ TAU( I ) ) IF( I.LT.M ) THEN * * Apply H(i) to A(i+1:m,i:n) from the right * - A( I, I ) = ONE - CALL CLARF( 'Right', M-I, N-I+1, A( I, I ), LDA, - $ TAU( I ), - $ A( I+1, I ), LDA, WORK ) + CALL CLARF1F( 'Right', M-I, N-I+1, A( I, I ), LDA, + $ TAU( I ), + $ A( I+1, I ), LDA, WORK ) END IF - A( I, I ) = ALPHA CALL CLACGV( N-I+1, A( I, I ), LDA ) 10 CONTINUE RETURN diff --git a/SRC/cgeql2.f b/SRC/cgeql2.f index c55c6d76ad..0161adb2e9 100644 --- a/SRC/cgeql2.f +++ b/SRC/cgeql2.f @@ -134,16 +134,11 @@ SUBROUTINE CGEQL2( M, N, A, LDA, TAU, WORK, INFO ) * * ===================================================================== * -* .. Parameters .. - COMPLEX ONE - PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ) ) -* .. * .. Local Scalars .. INTEGER I, K - COMPLEX ALPHA * .. * .. External Subroutines .. - EXTERNAL CLARF, CLARFG, XERBLA + EXTERNAL CLARF1L, CLARFG, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC CONJG, MAX, MIN @@ -172,15 +167,13 @@ SUBROUTINE CGEQL2( M, N, A, LDA, TAU, WORK, INFO ) * Generate elementary reflector H(i) to annihilate * A(1:m-k+i-1,n-k+i) * - ALPHA = A( M-K+I, N-K+I ) - CALL CLARFG( M-K+I, ALPHA, A( 1, N-K+I ), 1, TAU( I ) ) + CALL CLARFG( M-K+I, A( M-K+I, N-K+I ), A( 1, N-K+I ), 1, + $ TAU( I ) ) * * Apply H(i)**H to A(1:m-k+i,1:n-k+i-1) from the left * - A( M-K+I, N-K+I ) = ONE - CALL CLARF( 'Left', M-K+I, N-K+I-1, A( 1, N-K+I ), 1, - $ CONJG( TAU( I ) ), A, LDA, WORK ) - A( M-K+I, N-K+I ) = ALPHA + CALL CLARF1L( 'Left', M-K+I, N-K+I-1, A( 1, N-K+I ), 1, + $ CONJG( TAU( I ) ), A, LDA, WORK ) 10 CONTINUE RETURN * diff --git a/SRC/cgeqp3rk.f b/SRC/cgeqp3rk.f index 656c01ef89..b0173f6529 100644 --- a/SRC/cgeqp3rk.f +++ b/SRC/cgeqp3rk.f @@ -678,7 +678,7 @@ SUBROUTINE CGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, A, LDA, * 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 +* in CLARF1F subroutine inside CLAQP2RK to apply an * elementary reflector from the left. * TOTAL_WORK_SIZE = 3*N + NRHS - 1 * @@ -694,7 +694,7 @@ SUBROUTINE CGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, A, LDA, * 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 +* in CLARF1F 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 diff --git a/SRC/cgeqr2.f b/SRC/cgeqr2.f index 29dddb2085..4b6a4289ea 100644 --- a/SRC/cgeqr2.f +++ b/SRC/cgeqr2.f @@ -141,16 +141,11 @@ SUBROUTINE CGEQR2( M, N, A, LDA, TAU, WORK, INFO ) * * ===================================================================== * -* .. Parameters .. - COMPLEX ONE - PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ) ) -* .. * .. Local Scalars .. INTEGER I, K - COMPLEX ALPHA * .. * .. External Subroutines .. - EXTERNAL CLARF, CLARFG, XERBLA + EXTERNAL CLARF1F, CLARFG, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC CONJG, MAX, MIN @@ -184,11 +179,8 @@ SUBROUTINE CGEQR2( M, N, A, LDA, TAU, WORK, INFO ) * * Apply H(i)**H to A(i:m,i+1:n) from the left * - ALPHA = A( I, I ) - A( I, I ) = ONE - CALL CLARF( 'Left', M-I+1, N-I, A( I, I ), 1, - $ CONJG( TAU( I ) ), A( I, I+1 ), LDA, WORK ) - A( I, I ) = ALPHA + CALL CLARF1F( 'Left', M-I+1, N-I, A( I, I ), 1, + $ CONJG( TAU( I ) ), A( I, I+1 ), LDA, WORK ) END IF 10 CONTINUE RETURN diff --git a/SRC/cgeqr2p.f b/SRC/cgeqr2p.f index fb5012b49a..26c73f9b0b 100644 --- a/SRC/cgeqr2p.f +++ b/SRC/cgeqr2p.f @@ -145,16 +145,11 @@ SUBROUTINE CGEQR2P( M, N, A, LDA, TAU, WORK, INFO ) * * ===================================================================== * -* .. Parameters .. - COMPLEX ONE - PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ) ) -* .. * .. Local Scalars .. INTEGER I, K - COMPLEX ALPHA * .. * .. External Subroutines .. - EXTERNAL CLARF, CLARFGP, XERBLA + EXTERNAL CLARF1F, CLARFGP, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC CONJG, MAX, MIN @@ -188,11 +183,8 @@ SUBROUTINE CGEQR2P( M, N, A, LDA, TAU, WORK, INFO ) * * Apply H(i)**H to A(i:m,i+1:n) from the left * - ALPHA = A( I, I ) - A( I, I ) = ONE - CALL CLARF( 'Left', M-I+1, N-I, A( I, I ), 1, - $ CONJG( TAU( I ) ), A( I, I+1 ), LDA, WORK ) - A( I, I ) = ALPHA + CALL CLARF1F( 'Left', M-I+1, N-I, A( I, I ), 1, + $ CONJG( TAU( I ) ), A( I, I+1 ), LDA, WORK ) END IF 10 CONTINUE RETURN diff --git a/SRC/cgerq2.f b/SRC/cgerq2.f index ac1217118d..a7fa0609e6 100644 --- a/SRC/cgerq2.f +++ b/SRC/cgerq2.f @@ -134,16 +134,11 @@ SUBROUTINE CGERQ2( M, N, A, LDA, TAU, WORK, INFO ) * * ===================================================================== * -* .. Parameters .. - COMPLEX ONE - PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ) ) -* .. * .. Local Scalars .. INTEGER I, K - COMPLEX ALPHA * .. * .. External Subroutines .. - EXTERNAL CLACGV, CLARF, CLARFG, XERBLA + EXTERNAL CLACGV, CLARF1L, CLARFG, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN @@ -173,16 +168,13 @@ SUBROUTINE CGERQ2( M, N, A, LDA, TAU, WORK, INFO ) * A(m-k+i,1:n-k+i-1) * CALL CLACGV( N-K+I, A( M-K+I, 1 ), LDA ) - ALPHA = A( M-K+I, N-K+I ) - CALL CLARFG( N-K+I, ALPHA, A( M-K+I, 1 ), LDA, + CALL CLARFG( N-K+I, A( M-K+I, N-K+I ), A( M-K+I, 1 ), LDA, $ TAU( I ) ) * * Apply H(i) to A(1:m-k+i-1,1:n-k+i) from the right * - A( M-K+I, N-K+I ) = ONE - CALL CLARF( 'Right', M-K+I-1, N-K+I, A( M-K+I, 1 ), LDA, - $ TAU( I ), A, LDA, WORK ) - A( M-K+I, N-K+I ) = ALPHA + CALL CLARF1L( 'Right', M-K+I-1, N-K+I, A( M-K+I, 1 ), LDA, + $ TAU( I ), A, LDA, WORK ) CALL CLACGV( N-K+I-1, A( M-K+I, 1 ), LDA ) 10 CONTINUE RETURN diff --git a/SRC/claqp2.f b/SRC/claqp2.f index 544ddabc97..eb166af7ba 100644 --- a/SRC/claqp2.f +++ b/SRC/claqp2.f @@ -164,17 +164,14 @@ SUBROUTINE CLAQP2( M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2, * * .. Parameters .. REAL ZERO, ONE - COMPLEX CONE - PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0, - $ CONE = ( 1.0E+0, 0.0E+0 ) ) + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) * .. * .. Local Scalars .. INTEGER I, ITEMP, J, MN, OFFPI, PVT REAL TEMP, TEMP2, TOL3Z - COMPLEX AII * .. * .. External Subroutines .. - EXTERNAL CLARF, CLARFG, CSWAP + EXTERNAL CLARF1F, CLARFG, CSWAP * .. * .. Intrinsic Functions .. INTRINSIC ABS, CONJG, MAX, MIN, SQRT @@ -222,12 +219,9 @@ SUBROUTINE CLAQP2( M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2, * * Apply H(i)**H to A(offset+i:m,i+1:n) from the left. * - AII = A( OFFPI, I ) - A( OFFPI, I ) = CONE - CALL CLARF( 'Left', M-OFFPI+1, N-I, A( OFFPI, I ), 1, - $ CONJG( TAU( I ) ), A( OFFPI, I+1 ), LDA, - $ WORK( 1 ) ) - A( OFFPI, I ) = AII + CALL CLARF1F( 'Left', M-OFFPI+1, N-I, A( OFFPI, I ), 1, + $ CONJG( TAU( I ) ), A( OFFPI, I+1 ), LDA, + $ WORK( 1 ) ) END IF * * Update partial column norms. diff --git a/SRC/claqp2rk.f b/SRC/claqp2rk.f index 0501c50bb4..af19333dd4 100644 --- a/SRC/claqp2rk.f +++ b/SRC/claqp2rk.f @@ -254,7 +254,7 @@ *> \param[out] WORK *> \verbatim *> WORK is COMPLEX array, dimension (N-1) -*> Used in CLARF subroutine to apply an elementary +*> Used in CLARF1F subroutine to apply an elementary *> reflector from the left. *> \endverbatim *> @@ -364,18 +364,16 @@ SUBROUTINE CLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, * .. 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 ) ) + COMPLEX CZERO + PARAMETER ( CZERO = ( 0.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 + EXTERNAL CLARF1F, CLARFG, CSWAP * .. * .. Intrinsic Functions .. INTRINSIC ABS, REAL, CONJG, AIMAG, MAX, MIN, SQRT @@ -633,12 +631,9 @@ SUBROUTINE CLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, * 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 + CALL CLARF1F( 'Left', M-I+1, N+NRHS-KK, A( I, KK ), 1, + $ CONJG( TAU( KK ) ), A( I, KK+1 ), LDA, + $ WORK( 1 ) ) END IF * IF( KK.LT.MINMNFACT ) THEN diff --git a/SRC/claqr2.f b/SRC/claqr2.f index 6abdb615e5..526236eeed 100644 --- a/SRC/claqr2.f +++ b/SRC/claqr2.f @@ -292,7 +292,7 @@ SUBROUTINE CLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, PARAMETER ( RZERO = 0.0e0, RONE = 1.0e0 ) * .. * .. Local Scalars .. - COMPLEX BETA, CDUM, S, TAU + COMPLEX CDUM, S, TAU REAL FOO, SAFMAX, SAFMIN, SMLNUM, ULP INTEGER I, IFST, ILST, INFO, INFQR, J, JW, KCOL, KLN, $ KNT, KROW, KWTOP, LTOP, LWK1, LWK2, LWKOPT @@ -303,7 +303,7 @@ SUBROUTINE CLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, * .. * .. External Subroutines .. EXTERNAL CCOPY, CGEHRD, CGEMM, CLACPY, CLAHQR, - $ CLARF, + $ CLARF1F, $ CLARFG, CLASET, CTREXC, CUNMHR * .. * .. Intrinsic Functions .. @@ -475,19 +475,17 @@ SUBROUTINE CLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, DO 50 I = 1, NS WORK( I ) = CONJG( WORK( I ) ) 50 CONTINUE - BETA = WORK( 1 ) - CALL CLARFG( NS, BETA, WORK( 2 ), 1, TAU ) - WORK( 1 ) = ONE + CALL CLARFG( NS, WORK( 1 ), WORK( 2 ), 1, TAU ) * CALL CLASET( 'L', JW-2, JW-2, ZERO, ZERO, T( 3, 1 ), $ LDT ) * - CALL CLARF( 'L', NS, JW, WORK, 1, CONJG( TAU ), T, LDT, - $ WORK( JW+1 ) ) - CALL CLARF( 'R', NS, NS, WORK, 1, TAU, T, LDT, - $ WORK( JW+1 ) ) - CALL CLARF( 'R', JW, NS, WORK, 1, TAU, V, LDV, - $ WORK( JW+1 ) ) + CALL CLARF1F( 'L', NS, JW, WORK, 1, CONJG( TAU ), T, LDT, + $ WORK( JW+1 ) ) + CALL CLARF1F( 'R', NS, NS, WORK, 1, TAU, T, LDT, + $ WORK( JW+1 ) ) + CALL CLARF1F( 'R', JW, NS, WORK, 1, TAU, V, LDV, + $ WORK( JW+1 ) ) * CALL CGEHRD( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ), $ LWORK-JW, INFO ) diff --git a/SRC/claqr3.f b/SRC/claqr3.f index f516e5cfde..4d433b8cda 100644 --- a/SRC/claqr3.f +++ b/SRC/claqr3.f @@ -289,7 +289,7 @@ SUBROUTINE CLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, PARAMETER ( RZERO = 0.0e0, RONE = 1.0e0 ) * .. * .. Local Scalars .. - COMPLEX BETA, CDUM, S, TAU + COMPLEX CDUM, S, TAU REAL FOO, SAFMAX, SAFMIN, SMLNUM, ULP INTEGER I, IFST, ILST, INFO, INFQR, J, JW, KCOL, KLN, $ KNT, KROW, KWTOP, LTOP, LWK1, LWK2, LWK3, @@ -303,7 +303,7 @@ SUBROUTINE CLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, * .. External Subroutines .. EXTERNAL CCOPY, CGEHRD, CGEMM, CLACPY, CLAHQR, $ CLAQR4, - $ CLARF, CLARFG, CLASET, CTREXC, CUNMHR + $ CLARF1F, CLARFG, CLASET, CTREXC, CUNMHR * .. * .. Intrinsic Functions .. INTRINSIC ABS, AIMAG, CMPLX, CONJG, INT, MAX, MIN, REAL @@ -489,19 +489,17 @@ SUBROUTINE CLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, DO 50 I = 1, NS WORK( I ) = CONJG( WORK( I ) ) 50 CONTINUE - BETA = WORK( 1 ) - CALL CLARFG( NS, BETA, WORK( 2 ), 1, TAU ) - WORK( 1 ) = ONE + CALL CLARFG( NS, WORK( 1 ), WORK( 2 ), 1, TAU ) * CALL CLASET( 'L', JW-2, JW-2, ZERO, ZERO, T( 3, 1 ), $ LDT ) * - CALL CLARF( 'L', NS, JW, WORK, 1, CONJG( TAU ), T, LDT, - $ WORK( JW+1 ) ) - CALL CLARF( 'R', NS, NS, WORK, 1, TAU, T, LDT, - $ WORK( JW+1 ) ) - CALL CLARF( 'R', JW, NS, WORK, 1, TAU, V, LDV, - $ WORK( JW+1 ) ) + CALL CLARF1F( 'L', NS, JW, WORK, 1, CONJG( TAU ), T, LDT, + $ WORK( JW+1 ) ) + CALL CLARF1F( 'R', NS, NS, WORK, 1, TAU, T, LDT, + $ WORK( JW+1 ) ) + CALL CLARF1F( 'R', JW, NS, WORK, 1, TAU, V, LDV, + $ WORK( JW+1 ) ) * CALL CGEHRD( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ), $ LWORK-JW, INFO ) diff --git a/SRC/cunbdb.f b/SRC/cunbdb.f index 7abfb07d71..3401cb6983 100644 --- a/SRC/cunbdb.f +++ b/SRC/cunbdb.f @@ -307,8 +307,6 @@ SUBROUTINE CUNBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, * .. Parameters .. REAL REALONE PARAMETER ( REALONE = 1.0E0 ) - COMPLEX ONE - PARAMETER ( ONE = (1.0E0,0.0E0) ) * .. * .. Local Scalars .. LOGICAL COLMAJOR, LQUERY @@ -316,7 +314,7 @@ SUBROUTINE CUNBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, REAL Z1, Z2, Z3, Z4 * .. * .. External Subroutines .. - EXTERNAL CAXPY, CLARF, CLARFGP, CSCAL, + EXTERNAL CAXPY, CLARF1F, CLARFGP, CSCAL, $ XERBLA EXTERNAL CLACGV * @@ -425,7 +423,6 @@ SUBROUTINE CUNBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, ELSE IF ( P .EQ. I ) THEN CALL CLARFGP( P-I+1, X11(I,I), X11(I,I), 1, TAUP1(I) ) END IF - X11(I,I) = ONE IF ( M-P .GT. I ) THEN CALL CLARFGP( M-P-I+1, X21(I,I), X21(I+1,I), 1, $ TAUP2(I) ) @@ -433,19 +430,20 @@ SUBROUTINE CUNBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, CALL CLARFGP( M-P-I+1, X21(I,I), X21(I,I), 1, $ TAUP2(I) ) END IF - X21(I,I) = ONE * IF ( Q .GT. I ) THEN - CALL CLARF( 'L', P-I+1, Q-I, X11(I,I), 1, - $ CONJG(TAUP1(I)), X11(I,I+1), LDX11, WORK ) - CALL CLARF( 'L', M-P-I+1, Q-I, X21(I,I), 1, - $ CONJG(TAUP2(I)), X21(I,I+1), LDX21, WORK ) + CALL CLARF1F( 'L', P-I+1, Q-I, X11(I,I), 1, + $ CONJG(TAUP1(I)), X11(I,I+1), LDX11, + $ WORK ) + CALL CLARF1F( 'L', M-P-I+1, Q-I, X21(I,I), 1, + $ CONJG(TAUP2(I)), X21(I,I+1), LDX21, + $ WORK ) END IF IF ( M-Q+1 .GT. I ) THEN - CALL CLARF( 'L', P-I+1, M-Q-I+1, X11(I,I), 1, - $ CONJG(TAUP1(I)), X12(I,I), LDX12, WORK ) - CALL CLARF( 'L', M-P-I+1, M-Q-I+1, X21(I,I), 1, - $ CONJG(TAUP2(I)), X22(I,I), LDX22, WORK ) + CALL CLARF1F( 'L', P-I+1, M-Q-I+1, X11(I,I), 1, + $ CONJG(TAUP1(I)), X12(I,I), LDX12, WORK ) + CALL CLARF1F( 'L', M-P-I+1, M-Q-I+1, X21(I,I), 1, + $ CONJG(TAUP2(I)), X22(I,I), LDX22, WORK ) END IF * IF( I .LT. Q ) THEN @@ -473,7 +471,6 @@ SUBROUTINE CUNBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, CALL CLARFGP( Q-I, X11(I,I+1), X11(I,I+2), LDX11, $ TAUQ1(I) ) END IF - X11(I,I+1) = ONE END IF IF ( M-Q+1 .GT. I ) THEN CALL CLACGV( M-Q-I+1, X12(I,I), LDX12 ) @@ -485,24 +482,23 @@ SUBROUTINE CUNBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, $ TAUQ2(I) ) END IF END IF - X12(I,I) = ONE * IF( I .LT. Q ) THEN - CALL CLARF( 'R', P-I, Q-I, X11(I,I+1), LDX11, - $ TAUQ1(I), - $ X11(I+1,I+1), LDX11, WORK ) - CALL CLARF( 'R', M-P-I, Q-I, X11(I,I+1), LDX11, - $ TAUQ1(I), - $ X21(I+1,I+1), LDX21, WORK ) + CALL CLARF1F( 'R', P-I, Q-I, X11(I,I+1), LDX11, + $ TAUQ1(I), + $ X11(I+1,I+1), LDX11, WORK ) + CALL CLARF1F( 'R', M-P-I, Q-I, X11(I,I+1), LDX11, + $ TAUQ1(I), + $ X21(I+1,I+1), LDX21, WORK ) END IF IF ( P .GT. I ) THEN - CALL CLARF( 'R', P-I, M-Q-I+1, X12(I,I), LDX12, - $ TAUQ2(I), - $ X12(I+1,I), LDX12, WORK ) + CALL CLARF1F( 'R', P-I, M-Q-I+1, X12(I,I), LDX12, + $ TAUQ2(I), + $ X12(I+1,I), LDX12, WORK ) END IF IF ( M-P .GT. I ) THEN - CALL CLARF( 'R', M-P-I, M-Q-I+1, X12(I,I), LDX12, - $ TAUQ2(I), X22(I+1,I), LDX22, WORK ) + CALL CLARF1F( 'R', M-P-I, M-Q-I+1, X12(I,I), LDX12, + $ TAUQ2(I), X22(I+1,I), LDX22, WORK ) END IF * IF( I .LT. Q ) @@ -525,16 +521,15 @@ SUBROUTINE CUNBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, CALL CLARFGP( M-Q-I+1, X12(I,I), X12(I,I+1), LDX12, $ TAUQ2(I) ) END IF - X12(I,I) = ONE * IF ( P .GT. I ) THEN - CALL CLARF( 'R', P-I, M-Q-I+1, X12(I,I), LDX12, - $ TAUQ2(I), - $ X12(I+1,I), LDX12, WORK ) + CALL CLARF1F( 'R', P-I, M-Q-I+1, X12(I,I), LDX12, + $ TAUQ2(I), + $ X12(I+1,I), LDX12, WORK ) END IF IF( M-P-Q .GE. 1 ) - $ CALL CLARF( 'R', M-P-Q, M-Q-I+1, X12(I,I), LDX12, - $ TAUQ2(I), X22(Q+1,I), LDX22, WORK ) + $ CALL CLARF1F( 'R', M-P-Q, M-Q-I+1, X12(I,I), LDX12, + $ TAUQ2(I), X22(Q+1,I), LDX22, WORK ) * CALL CLACGV( M-Q-I+1, X12(I,I), LDX12 ) * @@ -549,9 +544,8 @@ SUBROUTINE CUNBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, CALL CLACGV( M-P-Q-I+1, X22(Q+I,P+I), LDX22 ) CALL CLARFGP( M-P-Q-I+1, X22(Q+I,P+I), X22(Q+I,P+I+1), $ LDX22, TAUQ2(P+I) ) - X22(Q+I,P+I) = ONE - CALL CLARF( 'R', M-P-Q-I, M-P-Q-I+1, X22(Q+I,P+I), LDX22, - $ TAUQ2(P+I), X22(Q+I+1,P+I), LDX22, WORK ) + CALL CLARF1F( 'R', M-P-Q-I, M-P-Q-I+1, X22(Q+I,P+I), LDX22, + $ TAUQ2(P+I), X22(Q+I+1,P+I), LDX22, WORK ) * CALL CLACGV( M-P-Q-I+1, X22(Q+I,P+I), LDX22 ) * @@ -590,7 +584,6 @@ SUBROUTINE CUNBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, * CALL CLARFGP( P-I+1, X11(I,I), X11(I,I+1), LDX11, $ TAUP1(I) ) - X11(I,I) = ONE IF ( I .EQ. M-P ) THEN CALL CLARFGP( M-P-I+1, X21(I,I), X21(I,I), LDX21, $ TAUP2(I) ) @@ -598,17 +591,16 @@ SUBROUTINE CUNBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, CALL CLARFGP( M-P-I+1, X21(I,I), X21(I,I+1), LDX21, $ TAUP2(I) ) END IF - X21(I,I) = ONE -* - CALL CLARF( 'R', Q-I, P-I+1, X11(I,I), LDX11, TAUP1(I), - $ X11(I+1,I), LDX11, WORK ) - CALL CLARF( 'R', M-Q-I+1, P-I+1, X11(I,I), LDX11, - $ TAUP1(I), - $ X12(I,I), LDX12, WORK ) - CALL CLARF( 'R', Q-I, M-P-I+1, X21(I,I), LDX21, TAUP2(I), - $ X21(I+1,I), LDX21, WORK ) - CALL CLARF( 'R', M-Q-I+1, M-P-I+1, X21(I,I), LDX21, - $ TAUP2(I), X22(I,I), LDX22, WORK ) +* + CALL CLARF1F( 'R', Q-I, P-I+1, X11(I,I), LDX11, TAUP1(I), + $ X11(I+1,I), LDX11, WORK ) + CALL CLARF1F( 'R', M-Q-I+1, P-I+1, X11(I,I), LDX11, + $ TAUP1(I), + $ X12(I,I), LDX12, WORK ) + CALL CLARF1F( 'R', Q-I, M-P-I+1, X21(I,I), LDX21, + $ TAUP2(I), X21(I+1,I), LDX21, WORK ) + CALL CLARF1F( 'R', M-Q-I+1, M-P-I+1, X21(I,I), LDX21, + $ TAUP2(I), X22(I,I), LDX22, WORK ) * CALL CLACGV( P-I+1, X11(I,I), LDX11 ) CALL CLACGV( M-P-I+1, X21(I,I), LDX21 ) @@ -632,25 +624,26 @@ SUBROUTINE CUNBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, IF( I .LT. Q ) THEN CALL CLARFGP( Q-I, X11(I+1,I), X11(I+2,I), 1, $ TAUQ1(I) ) - X11(I+1,I) = ONE END IF CALL CLARFGP( M-Q-I+1, X12(I,I), X12(I+1,I), 1, $ TAUQ2(I) ) - X12(I,I) = ONE * IF( I .LT. Q ) THEN - CALL CLARF( 'L', Q-I, P-I, X11(I+1,I), 1, - $ CONJG(TAUQ1(I)), X11(I+1,I+1), LDX11, WORK ) - CALL CLARF( 'L', Q-I, M-P-I, X11(I+1,I), 1, - $ CONJG(TAUQ1(I)), X21(I+1,I+1), LDX21, WORK ) + CALL CLARF1F( 'L', Q-I, P-I, X11(I+1,I), 1, + $ CONJG(TAUQ1(I)), X11(I+1,I+1), LDX11, + $ WORK ) + CALL CLARF1F( 'L', Q-I, M-P-I, X11(I+1,I), 1, + $ CONJG(TAUQ1(I)), X21(I+1,I+1), LDX21, + $ WORK ) END IF - CALL CLARF( 'L', M-Q-I+1, P-I, X12(I,I), 1, - $ CONJG(TAUQ2(I)), - $ X12(I,I+1), LDX12, WORK ) + CALL CLARF1F( 'L', M-Q-I+1, P-I, X12(I,I), 1, + $ CONJG(TAUQ2(I)), + $ X12(I,I+1), LDX12, WORK ) IF ( M-P .GT. I ) THEN - CALL CLARF( 'L', M-Q-I+1, M-P-I, X12(I,I), 1, - $ CONJG(TAUQ2(I)), X22(I,I+1), LDX22, WORK ) + CALL CLARF1F( 'L', M-Q-I+1, M-P-I, X12(I,I), 1, + $ CONJG(TAUQ2(I)), X22(I,I+1), LDX22, + $ WORK ) END IF END DO * @@ -662,15 +655,16 @@ SUBROUTINE CUNBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, $ 1 ) CALL CLARFGP( M-Q-I+1, X12(I,I), X12(I+1,I), 1, $ TAUQ2(I) ) - X12(I,I) = ONE * IF ( P .GT. I ) THEN - CALL CLARF( 'L', M-Q-I+1, P-I, X12(I,I), 1, - $ CONJG(TAUQ2(I)), X12(I,I+1), LDX12, WORK ) + CALL CLARF1F( 'L', M-Q-I+1, P-I, X12(I,I), 1, + $ CONJG(TAUQ2(I)), X12(I,I+1), LDX12, + $ WORK ) END IF IF( M-P-Q .GE. 1 ) - $ CALL CLARF( 'L', M-Q-I+1, M-P-Q, X12(I,I), 1, - $ CONJG(TAUQ2(I)), X22(I,Q+1), LDX22, WORK ) + $ CALL CLARF1F( 'L', M-Q-I+1, M-P-Q, X12(I,I), 1, + $ CONJG(TAUQ2(I)), X22(I,Q+1), LDX22, + $ WORK ) * END DO * @@ -682,11 +676,10 @@ SUBROUTINE CUNBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, $ X22(P+I,Q+I), 1 ) CALL CLARFGP( M-P-Q-I+1, X22(P+I,Q+I), X22(P+I+1,Q+I), 1, $ TAUQ2(P+I) ) - X22(P+I,Q+I) = ONE IF ( M-P-Q .NE. I ) THEN - CALL CLARF( 'L', M-P-Q-I+1, M-P-Q-I, X22(P+I,Q+I), 1, - $ CONJG(TAUQ2(P+I)), X22(P+I,Q+I+1), LDX22, - $ WORK ) + CALL CLARF1F( 'L', M-P-Q-I+1, M-P-Q-I, X22(P+I,Q+I), + $ 1, CONJG(TAUQ2(P+I)), X22(P+I,Q+I+1), + $ LDX22, WORK ) END IF END DO * diff --git a/SRC/cunbdb1.f b/SRC/cunbdb1.f index 1c096a4bd2..8acc019fb2 100644 --- a/SRC/cunbdb1.f +++ b/SRC/cunbdb1.f @@ -216,10 +216,6 @@ SUBROUTINE CUNBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, * * ==================================================================== * -* .. Parameters .. - COMPLEX ONE - PARAMETER ( ONE = (1.0E0,0.0E0) ) -* .. * .. Local Scalars .. REAL C, S INTEGER CHILDINFO, I, ILARF, IORBDB5, LLARF, LORBDB5, @@ -227,7 +223,7 @@ SUBROUTINE CUNBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, LOGICAL LQUERY * .. * .. External Subroutines .. - EXTERNAL CLARF, CLARFGP, CUNBDB5, CSROT, + EXTERNAL CLARF1F, CLARFGP, CUNBDB5, CSROT, $ XERBLA EXTERNAL CLACGV * .. @@ -287,12 +283,11 @@ SUBROUTINE CUNBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, THETA(I) = ATAN2( REAL( X21(I,I) ), REAL( X11(I,I) ) ) C = COS( THETA(I) ) S = SIN( THETA(I) ) - X11(I,I) = ONE - X21(I,I) = ONE - CALL CLARF( 'L', P-I+1, Q-I, X11(I,I), 1, CONJG(TAUP1(I)), - $ X11(I,I+1), LDX11, WORK(ILARF) ) - CALL CLARF( 'L', M-P-I+1, Q-I, X21(I,I), 1, CONJG(TAUP2(I)), - $ X21(I,I+1), LDX21, WORK(ILARF) ) + CALL CLARF1F( 'L', P-I+1, Q-I, X11(I,I), 1, CONJG(TAUP1(I)), + $ X11(I,I+1), LDX11, WORK(ILARF) ) + CALL CLARF1F( 'L', M-P-I+1, Q-I, X21(I,I), 1, + $ CONJG(TAUP2(I)), X21(I,I+1), LDX21, + $ WORK(ILARF) ) * IF( I .LT. Q ) THEN CALL CSROT( Q-I, X11(I,I+1), LDX11, X21(I,I+1), LDX21, C, @@ -301,11 +296,11 @@ SUBROUTINE CUNBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, CALL CLARFGP( Q-I, X21(I,I+1), X21(I,I+2), LDX21, $ TAUQ1(I) ) S = REAL( X21(I,I+1) ) - X21(I,I+1) = ONE - CALL CLARF( 'R', P-I, Q-I, X21(I,I+1), LDX21, TAUQ1(I), - $ X11(I+1,I+1), LDX11, WORK(ILARF) ) - CALL CLARF( 'R', M-P-I, Q-I, X21(I,I+1), LDX21, TAUQ1(I), - $ X21(I+1,I+1), LDX21, WORK(ILARF) ) + CALL CLARF1F( 'R', P-I, Q-I, X21(I,I+1), LDX21, TAUQ1(I), + $ X11(I+1,I+1), LDX11, WORK(ILARF) ) + CALL CLARF1F( 'R', M-P-I, Q-I, X21(I,I+1), LDX21, + $ TAUQ1(I), X21(I+1,I+1), LDX21, + $ WORK(ILARF) ) CALL CLACGV( Q-I, X21(I,I+1), LDX21 ) C = SQRT( SCNRM2( P-I, X11(I+1,I+1), 1 )**2 $ + SCNRM2( M-P-I, X21(I+1,I+1), 1 )**2 ) diff --git a/SRC/cunbdb2.f b/SRC/cunbdb2.f index 737d0e773b..e9416679ec 100644 --- a/SRC/cunbdb2.f +++ b/SRC/cunbdb2.f @@ -217,9 +217,8 @@ SUBROUTINE CUNBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, * ==================================================================== * * .. Parameters .. - COMPLEX NEGONE, ONE - PARAMETER ( NEGONE = (-1.0E0,0.0E0), - $ ONE = (1.0E0,0.0E0) ) + COMPLEX NEGONE + PARAMETER ( NEGONE = (-1.0E0,0.0E0) ) * .. * .. Local Scalars .. REAL C, S @@ -228,7 +227,7 @@ SUBROUTINE CUNBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, LOGICAL LQUERY * .. * .. External Subroutines .. - EXTERNAL CLARF, CLARFGP, CUNBDB5, CSROT, CSCAL, + EXTERNAL CLARF1F, CLARFGP, CUNBDB5, CSROT, CSCAL, $ CLACGV, $ XERBLA * .. @@ -290,11 +289,10 @@ SUBROUTINE CUNBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, CALL CLACGV( Q-I+1, X11(I,I), LDX11 ) CALL CLARFGP( Q-I+1, X11(I,I), X11(I,I+1), LDX11, TAUQ1(I) ) C = REAL( X11(I,I) ) - X11(I,I) = ONE - CALL CLARF( 'R', P-I, Q-I+1, X11(I,I), LDX11, TAUQ1(I), - $ X11(I+1,I), LDX11, WORK(ILARF) ) - CALL CLARF( 'R', M-P-I+1, Q-I+1, X11(I,I), LDX11, TAUQ1(I), - $ X21(I,I), LDX21, WORK(ILARF) ) + CALL CLARF1F( 'R', P-I, Q-I+1, X11(I,I), LDX11, TAUQ1(I), + $ X11(I+1,I), LDX11, WORK(ILARF) ) + CALL CLARF1F( 'R', M-P-I+1, Q-I+1, X11(I,I), LDX11, + $ TAUQ1(I), X21(I,I), LDX21, WORK(ILARF) ) CALL CLACGV( Q-I+1, X11(I,I), LDX11 ) S = SQRT( SCNRM2( P-I, X11(I+1,I), 1 )**2 $ + SCNRM2( M-P-I+1, X21(I,I), 1 )**2 ) @@ -310,14 +308,13 @@ SUBROUTINE CUNBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI(I) = ATAN2( REAL( X11(I+1,I) ), REAL( X21(I,I) ) ) C = COS( PHI(I) ) S = SIN( PHI(I) ) - X11(I+1,I) = ONE - CALL CLARF( 'L', P-I, Q-I, X11(I+1,I), 1, - $ CONJG(TAUP1(I)), - $ X11(I+1,I+1), LDX11, WORK(ILARF) ) + CALL CLARF1F( 'L', P-I, Q-I, X11(I+1,I), 1, + $ CONJG(TAUP1(I)), + $ X11(I+1,I+1), LDX11, WORK(ILARF) ) END IF - X21(I,I) = ONE - CALL CLARF( 'L', M-P-I+1, Q-I, X21(I,I), 1, CONJG(TAUP2(I)), - $ X21(I,I+1), LDX21, WORK(ILARF) ) + CALL CLARF1F( 'L', M-P-I+1, Q-I, X21(I,I), 1, + $ CONJG(TAUP2(I)), X21(I,I+1), LDX21, + $ WORK(ILARF) ) * END DO * @@ -325,9 +322,9 @@ SUBROUTINE CUNBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, * DO I = P + 1, Q CALL CLARFGP( M-P-I+1, X21(I,I), X21(I+1,I), 1, TAUP2(I) ) - X21(I,I) = ONE - CALL CLARF( 'L', M-P-I+1, Q-I, X21(I,I), 1, CONJG(TAUP2(I)), - $ X21(I,I+1), LDX21, WORK(ILARF) ) + CALL CLARF1F( 'L', M-P-I+1, Q-I, X21(I,I), 1, + $ CONJG(TAUP2(I)), X21(I,I+1), LDX21, + $ WORK(ILARF) ) END DO * RETURN diff --git a/SRC/cunbdb3.f b/SRC/cunbdb3.f index 91ae5f8954..2425a565eb 100644 --- a/SRC/cunbdb3.f +++ b/SRC/cunbdb3.f @@ -216,10 +216,6 @@ SUBROUTINE CUNBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, * * ==================================================================== * -* .. Parameters .. - COMPLEX ONE - PARAMETER ( ONE = (1.0E0,0.0E0) ) -* .. * .. Local Scalars .. REAL C, S INTEGER CHILDINFO, I, ILARF, IORBDB5, LLARF, LORBDB5, @@ -227,7 +223,7 @@ SUBROUTINE CUNBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, LOGICAL LQUERY * .. * .. External Subroutines .. - EXTERNAL CLARF, CLARFGP, CUNBDB5, CSROT, CLACGV, + EXTERNAL CLARF1F, CLARFGP, CUNBDB5, CSROT, CLACGV, $ XERBLA * .. * .. External Functions .. @@ -289,11 +285,10 @@ SUBROUTINE CUNBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, CALL CLACGV( Q-I+1, X21(I,I), LDX21 ) CALL CLARFGP( Q-I+1, X21(I,I), X21(I,I+1), LDX21, TAUQ1(I) ) S = REAL( X21(I,I) ) - X21(I,I) = ONE - CALL CLARF( 'R', P-I+1, Q-I+1, X21(I,I), LDX21, TAUQ1(I), - $ X11(I,I), LDX11, WORK(ILARF) ) - CALL CLARF( 'R', M-P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I), - $ X21(I+1,I), LDX21, WORK(ILARF) ) + CALL CLARF1F( 'R', P-I+1, Q-I+1, X21(I,I), LDX21, TAUQ1(I), + $ X11(I,I), LDX11, WORK(ILARF) ) + CALL CLARF1F( 'R', M-P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I), + $ X21(I+1,I), LDX21, WORK(ILARF) ) CALL CLACGV( Q-I+1, X21(I,I), LDX21 ) C = SQRT( SCNRM2( P-I+1, X11(I,I), 1 )**2 $ + SCNRM2( M-P-I, X21(I+1,I), 1 )**2 ) @@ -309,14 +304,12 @@ SUBROUTINE CUNBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI(I) = ATAN2( REAL( X21(I+1,I) ), REAL( X11(I,I) ) ) C = COS( PHI(I) ) S = SIN( PHI(I) ) - X21(I+1,I) = ONE - CALL CLARF( 'L', M-P-I, Q-I, X21(I+1,I), 1, - $ CONJG(TAUP2(I)), - $ X21(I+1,I+1), LDX21, WORK(ILARF) ) + CALL CLARF1F( 'L', M-P-I, Q-I, X21(I+1,I), 1, + $ CONJG(TAUP2(I)), + $ X21(I+1,I+1), LDX21, WORK(ILARF) ) END IF - X11(I,I) = ONE - CALL CLARF( 'L', P-I+1, Q-I, X11(I,I), 1, CONJG(TAUP1(I)), - $ X11(I,I+1), LDX11, WORK(ILARF) ) + CALL CLARF1F( 'L', P-I+1, Q-I, X11(I,I), 1, CONJG(TAUP1(I)), + $ X11(I,I+1), LDX11, WORK(ILARF) ) * END DO * @@ -324,9 +317,8 @@ SUBROUTINE CUNBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, * DO I = M-P + 1, Q CALL CLARFGP( P-I+1, X11(I,I), X11(I+1,I), 1, TAUP1(I) ) - X11(I,I) = ONE - CALL CLARF( 'L', P-I+1, Q-I, X11(I,I), 1, CONJG(TAUP1(I)), - $ X11(I,I+1), LDX11, WORK(ILARF) ) + CALL CLARF1F( 'L', P-I+1, Q-I, X11(I,I), 1, CONJG(TAUP1(I)), + $ X11(I,I+1), LDX11, WORK(ILARF) ) END DO * RETURN diff --git a/SRC/cunbdb4.f b/SRC/cunbdb4.f index 71d35a7118..65f2717c5d 100644 --- a/SRC/cunbdb4.f +++ b/SRC/cunbdb4.f @@ -228,8 +228,8 @@ SUBROUTINE CUNBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, * ==================================================================== * * .. Parameters .. - COMPLEX NEGONE, ONE, ZERO - PARAMETER ( NEGONE = (-1.0E0,0.0E0), ONE = (1.0E0,0.0E0), + COMPLEX NEGONE, ZERO + PARAMETER ( NEGONE = (-1.0E0,0.0E0), $ ZERO = (0.0E0,0.0E0) ) * .. * .. Local Scalars .. @@ -239,7 +239,7 @@ SUBROUTINE CUNBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, LOGICAL LQUERY * .. * .. External Subroutines .. - EXTERNAL CLARF, CLARFGP, CUNBDB5, CSROT, CSCAL, + EXTERNAL CLARF1F, CLARFGP, CUNBDB5, CSROT, CSCAL, $ CLACGV, $ XERBLA * .. @@ -309,14 +309,12 @@ SUBROUTINE CUNBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, THETA(I) = ATAN2( REAL( PHANTOM(1) ), REAL( PHANTOM(P+1) ) ) C = COS( THETA(I) ) S = SIN( THETA(I) ) - PHANTOM(1) = ONE - PHANTOM(P+1) = ONE - CALL CLARF( 'L', P, Q, PHANTOM(1), 1, CONJG(TAUP1(1)), - $ X11, - $ LDX11, WORK(ILARF) ) - CALL CLARF( 'L', M-P, Q, PHANTOM(P+1), 1, - $ CONJG(TAUP2(1)), - $ X21, LDX21, WORK(ILARF) ) + CALL CLARF1F( 'L', P, Q, PHANTOM(1), 1, CONJG(TAUP1(1)), + $ X11, + $ LDX11, WORK(ILARF) ) + CALL CLARF1F( 'L', M-P, Q, PHANTOM(P+1), 1, + $ CONJG(TAUP2(1)), + $ X21, LDX21, WORK(ILARF) ) ELSE CALL CUNBDB5( P-I+1, M-P-I+1, Q-I+1, X11(I,I-1), 1, $ X21(I,I-1), 1, X11(I,I), LDX11, X21(I,I), @@ -329,23 +327,22 @@ SUBROUTINE CUNBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, THETA(I) = ATAN2( REAL( X11(I,I-1) ), REAL( X21(I,I-1) ) ) C = COS( THETA(I) ) S = SIN( THETA(I) ) - X11(I,I-1) = ONE - X21(I,I-1) = ONE - CALL CLARF( 'L', P-I+1, Q-I+1, X11(I,I-1), 1, - $ CONJG(TAUP1(I)), X11(I,I), LDX11, WORK(ILARF) ) - CALL CLARF( 'L', M-P-I+1, Q-I+1, X21(I,I-1), 1, - $ CONJG(TAUP2(I)), X21(I,I), LDX21, WORK(ILARF) ) + CALL CLARF1F( 'L', P-I+1, Q-I+1, X11(I,I-1), 1, + $ CONJG(TAUP1(I)), X11(I,I), LDX11, + $ WORK(ILARF) ) + CALL CLARF1F( 'L', M-P-I+1, Q-I+1, X21(I,I-1), 1, + $ CONJG(TAUP2(I)), X21(I,I), LDX21, + $ WORK(ILARF) ) END IF * CALL CSROT( Q-I+1, X11(I,I), LDX11, X21(I,I), LDX21, S, -C ) CALL CLACGV( Q-I+1, X21(I,I), LDX21 ) CALL CLARFGP( Q-I+1, X21(I,I), X21(I,I+1), LDX21, TAUQ1(I) ) C = REAL( X21(I,I) ) - X21(I,I) = ONE - CALL CLARF( 'R', P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I), - $ X11(I+1,I), LDX11, WORK(ILARF) ) - CALL CLARF( 'R', M-P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I), - $ X21(I+1,I), LDX21, WORK(ILARF) ) + CALL CLARF1F( 'R', P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I), + $ X11(I+1,I), LDX11, WORK(ILARF) ) + CALL CLARF1F( 'R', M-P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I), + $ X21(I+1,I), LDX21, WORK(ILARF) ) CALL CLACGV( Q-I+1, X21(I,I), LDX21 ) IF( I .LT. M-Q ) THEN S = SQRT( SCNRM2( P-I, X11(I+1,I), 1 )**2 @@ -360,11 +357,10 @@ SUBROUTINE CUNBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, DO I = M - Q + 1, P CALL CLACGV( Q-I+1, X11(I,I), LDX11 ) CALL CLARFGP( Q-I+1, X11(I,I), X11(I,I+1), LDX11, TAUQ1(I) ) - X11(I,I) = ONE - CALL CLARF( 'R', P-I, Q-I+1, X11(I,I), LDX11, TAUQ1(I), - $ X11(I+1,I), LDX11, WORK(ILARF) ) - CALL CLARF( 'R', Q-P, Q-I+1, X11(I,I), LDX11, TAUQ1(I), - $ X21(M-Q+1,I), LDX21, WORK(ILARF) ) + CALL CLARF1F( 'R', P-I, Q-I+1, X11(I,I), LDX11, TAUQ1(I), + $ X11(I+1,I), LDX11, WORK(ILARF) ) + CALL CLARF1F( 'R', Q-P, Q-I+1, X11(I,I), LDX11, TAUQ1(I), + $ X21(M-Q+1,I), LDX21, WORK(ILARF) ) CALL CLACGV( Q-I+1, X11(I,I), LDX11 ) END DO * @@ -375,10 +371,9 @@ SUBROUTINE CUNBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, CALL CLARFGP( Q-I+1, X21(M-Q+I-P,I), X21(M-Q+I-P,I+1), $ LDX21, $ TAUQ1(I) ) - X21(M-Q+I-P,I) = ONE - CALL CLARF( 'R', Q-I, Q-I+1, X21(M-Q+I-P,I), LDX21, - $ TAUQ1(I), - $ X21(M-Q+I-P+1,I), LDX21, WORK(ILARF) ) + CALL CLARF1F( 'R', Q-I, Q-I+1, X21(M-Q+I-P,I), LDX21, + $ TAUQ1(I), + $ X21(M-Q+I-P+1,I), LDX21, WORK(ILARF) ) CALL CLACGV( Q-I+1, X21(M-Q+I-P,I), LDX21 ) END DO * diff --git a/SRC/cung2l.f b/SRC/cung2l.f index 602f1c8ef9..10536022c8 100644 --- a/SRC/cung2l.f +++ b/SRC/cung2l.f @@ -134,7 +134,7 @@ SUBROUTINE CUNG2L( M, N, K, A, LDA, TAU, WORK, INFO ) INTEGER I, II, J, L * .. * .. External Subroutines .. - EXTERNAL CLARF, CSCAL, XERBLA + EXTERNAL CLARF1L, CSCAL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX @@ -178,9 +178,9 @@ SUBROUTINE CUNG2L( M, N, K, A, LDA, TAU, WORK, INFO ) * Apply H(i) to A(1:m-k+i,1:n-k+i) from the left * A( M-N+II, II ) = ONE - CALL CLARF( 'Left', M-N+II, II-1, A( 1, II ), 1, TAU( I ), - $ A, - $ LDA, WORK ) + CALL CLARF1L( 'Left', M-N+II, II-1, A( 1, II ), 1, TAU( I ), + $ A, + $ LDA, WORK ) CALL CSCAL( M-N+II-1, -TAU( I ), A( 1, II ), 1 ) A( M-N+II, II ) = ONE - TAU( I ) * diff --git a/SRC/cung2r.f b/SRC/cung2r.f index d854ed437f..2d529f672e 100644 --- a/SRC/cung2r.f +++ b/SRC/cung2r.f @@ -134,7 +134,7 @@ SUBROUTINE CUNG2R( M, N, K, A, LDA, TAU, WORK, INFO ) INTEGER I, J, L * .. * .. External Subroutines .. - EXTERNAL CLARF, CSCAL, XERBLA + EXTERNAL CLARF1F, CSCAL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX @@ -177,9 +177,8 @@ SUBROUTINE CUNG2R( M, N, K, A, LDA, TAU, WORK, INFO ) * Apply H(i) to A(i:m,i:n) from the left * IF( I.LT.N ) THEN - A( I, I ) = ONE - CALL CLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ), - $ A( I, I+1 ), LDA, WORK ) + CALL CLARF1F( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ), + $ A( I, I+1 ), LDA, WORK ) END IF IF( I.LT.M ) $ CALL CSCAL( M-I, -TAU( I ), A( I+1, I ), 1 ) diff --git a/SRC/cungl2.f b/SRC/cungl2.f index 4e5042b636..c4b4a272e0 100644 --- a/SRC/cungl2.f +++ b/SRC/cungl2.f @@ -133,7 +133,7 @@ SUBROUTINE CUNGL2( M, N, K, A, LDA, TAU, WORK, INFO ) INTEGER I, J, L * .. * .. External Subroutines .. - EXTERNAL CLACGV, CLARF, CSCAL, XERBLA + EXTERNAL CLACGV, CLARF1F, CSCAL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC CONJG, MAX @@ -182,9 +182,9 @@ SUBROUTINE CUNGL2( M, N, K, A, LDA, TAU, WORK, INFO ) IF( I.LT.N ) THEN CALL CLACGV( N-I, A( I, I+1 ), LDA ) IF( I.LT.M ) THEN - A( I, I ) = ONE - CALL CLARF( 'Right', M-I, N-I+1, A( I, I ), LDA, - $ CONJG( TAU( I ) ), A( I+1, I ), LDA, WORK ) + CALL CLARF1F( 'Right', M-I, N-I+1, A( I, I ), LDA, + $ CONJG( TAU( I ) ), A( I+1, I ), LDA, + $ WORK ) END IF CALL CSCAL( N-I, -TAU( I ), A( I, I+1 ), LDA ) CALL CLACGV( N-I, A( I, I+1 ), LDA ) diff --git a/SRC/cungr2.f b/SRC/cungr2.f index 1e99911121..fbae716a24 100644 --- a/SRC/cungr2.f +++ b/SRC/cungr2.f @@ -134,7 +134,7 @@ SUBROUTINE CUNGR2( M, N, K, A, LDA, TAU, WORK, INFO ) INTEGER I, II, J, L * .. * .. External Subroutines .. - EXTERNAL CLACGV, CLARF, CSCAL, XERBLA + EXTERNAL CLACGV, CLARF1L, CSCAL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC CONJG, MAX @@ -183,8 +183,8 @@ SUBROUTINE CUNGR2( M, N, K, A, LDA, TAU, WORK, INFO ) * CALL CLACGV( N-M+II-1, A( II, 1 ), LDA ) A( II, N-M+II ) = ONE - CALL CLARF( 'Right', II-1, N-M+II, A( II, 1 ), LDA, - $ CONJG( TAU( I ) ), A, LDA, WORK ) + CALL CLARF1L( 'Right', II-1, N-M+II, A( II, 1 ), LDA, + $ CONJG( TAU( I ) ), A, LDA, WORK ) CALL CSCAL( N-M+II-1, -TAU( I ), A( II, 1 ), LDA ) CALL CLACGV( N-M+II-1, A( II, 1 ), LDA ) A( II, N-M+II ) = ONE - CONJG( TAU( I ) ) diff --git a/SRC/cunm2l.f b/SRC/cunm2l.f index 238b73525e..cb08b03c99 100644 --- a/SRC/cunm2l.f +++ b/SRC/cunm2l.f @@ -171,21 +171,17 @@ SUBROUTINE CUNM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, * * ===================================================================== * -* .. Parameters .. - COMPLEX ONE - PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ) ) -* .. * .. Local Scalars .. LOGICAL LEFT, NOTRAN INTEGER I, I1, I2, I3, MI, NI, NQ - COMPLEX AII, TAUI + COMPLEX TAUI * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. - EXTERNAL CLARF, XERBLA + EXTERNAL CLARF1L, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC CONJG, MAX @@ -266,10 +262,8 @@ SUBROUTINE CUNM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, ELSE TAUI = CONJG( TAU( I ) ) END IF - AII = A( NQ-K+I, I ) - A( NQ-K+I, I ) = ONE - CALL CLARF( SIDE, MI, NI, A( 1, I ), 1, TAUI, C, LDC, WORK ) - A( NQ-K+I, I ) = AII + CALL CLARF1L( SIDE, MI, NI, A( 1, I ), 1, TAUI, C, LDC, + $ WORK ) 10 CONTINUE RETURN * diff --git a/SRC/cunm2r.f b/SRC/cunm2r.f index 094a15bf7c..07238cd416 100644 --- a/SRC/cunm2r.f +++ b/SRC/cunm2r.f @@ -171,10 +171,6 @@ SUBROUTINE CUNM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, * * ===================================================================== * -* .. Parameters .. - COMPLEX ONE - PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ) ) -* .. * .. Local Scalars .. LOGICAL LEFT, NOTRAN INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ @@ -270,7 +266,6 @@ SUBROUTINE CUNM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, ELSE TAUI = CONJG( TAU( I ) ) END IF - A( I, I ) = ONE CALL CLARF1F( SIDE, MI, NI, A( I, I ), 1, TAUI, C( IC, JC ), $ LDC, $ WORK ) diff --git a/SRC/cunml2.f b/SRC/cunml2.f index a00ce5ff0c..f2a9d542fc 100644 --- a/SRC/cunml2.f +++ b/SRC/cunml2.f @@ -171,21 +171,17 @@ SUBROUTINE CUNML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, * * ===================================================================== * -* .. Parameters .. - COMPLEX ONE - PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ) ) -* .. * .. Local Scalars .. LOGICAL LEFT, NOTRAN INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ - COMPLEX AII, TAUI + COMPLEX TAUI * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. - EXTERNAL CLACGV, CLARF, XERBLA + EXTERNAL CLACGV, CLARF1F, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC CONJG, MAX @@ -272,11 +268,8 @@ SUBROUTINE CUNML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, END IF IF( I.LT.NQ ) $ CALL CLACGV( NQ-I, A( I, I+1 ), LDA ) - AII = A( I, I ) - A( I, I ) = ONE - CALL CLARF( SIDE, MI, NI, A( I, I ), LDA, TAUI, C( IC, JC ), - $ LDC, WORK ) - A( I, I ) = AII + CALL CLARF1F( SIDE, MI, NI, A( I, I ), LDA, TAUI, C( IC, + $ JC ), LDC, WORK ) IF( I.LT.NQ ) $ CALL CLACGV( NQ-I, A( I, I+1 ), LDA ) 10 CONTINUE diff --git a/SRC/cunmr2.f b/SRC/cunmr2.f index 69988e84ab..1cfa860a83 100644 --- a/SRC/cunmr2.f +++ b/SRC/cunmr2.f @@ -171,21 +171,17 @@ SUBROUTINE CUNMR2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, * * ===================================================================== * -* .. Parameters .. - COMPLEX ONE - PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ) ) -* .. * .. Local Scalars .. LOGICAL LEFT, NOTRAN INTEGER I, I1, I2, I3, MI, NI, NQ - COMPLEX AII, TAUI + COMPLEX TAUI * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. - EXTERNAL CLACGV, CLARF, XERBLA + EXTERNAL CLACGV, CLARF1L, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC CONJG, MAX @@ -267,11 +263,8 @@ SUBROUTINE CUNMR2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, TAUI = TAU( I ) END IF CALL CLACGV( NQ-K+I-1, A( I, 1 ), LDA ) - AII = A( I, NQ-K+I ) - A( I, NQ-K+I ) = ONE - CALL CLARF( SIDE, MI, NI, A( I, 1 ), LDA, TAUI, C, LDC, - $ WORK ) - A( I, NQ-K+I ) = AII + CALL CLARF1L( SIDE, MI, NI, A( I, 1 ), LDA, TAUI, C, LDC, + $ WORK ) CALL CLACGV( NQ-K+I-1, A( I, 1 ), LDA ) 10 CONTINUE RETURN diff --git a/SRC/cupmtr.f b/SRC/cupmtr.f index 6f82851911..6faab0105a 100644 --- a/SRC/cupmtr.f +++ b/SRC/cupmtr.f @@ -163,21 +163,17 @@ SUBROUTINE CUPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC, * * ===================================================================== * -* .. Parameters .. - COMPLEX ONE - PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ) ) -* .. * .. Local Scalars .. LOGICAL FORWRD, LEFT, NOTRAN, UPPER INTEGER I, I1, I2, I3, IC, II, JC, MI, NI, NQ - COMPLEX AII, TAUI + COMPLEX TAUI * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. - EXTERNAL CLARF, XERBLA + EXTERNAL CLARF1F, CLARF1L, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC CONJG, MAX @@ -266,11 +262,8 @@ SUBROUTINE CUPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC, ELSE TAUI = CONJG( TAU( I ) ) END IF - AII = AP( II ) - AP( II ) = ONE - CALL CLARF( SIDE, MI, NI, AP( II-I+1 ), 1, TAUI, C, LDC, - $ WORK ) - AP( II ) = AII + CALL CLARF1L( SIDE, MI, NI, AP( II-I+1 ), 1, TAUI, C, + $ LDC, WORK ) * IF( FORWRD ) THEN II = II + I + 2 @@ -306,8 +299,6 @@ SUBROUTINE CUPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC, END IF * DO 20 I = I1, I2, I3 - AII = AP( II ) - AP( II ) = ONE IF( LEFT ) THEN * * H(i) or H(i)**H is applied to C(i+1:m,1:n) @@ -329,9 +320,8 @@ SUBROUTINE CUPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC, ELSE TAUI = CONJG( TAU( I ) ) END IF - CALL CLARF( SIDE, MI, NI, AP( II ), 1, TAUI, C( IC, JC ), - $ LDC, WORK ) - AP( II ) = AII + CALL CLARF1F( SIDE, MI, NI, AP( II ), 1, TAUI, C( IC, + $ JC ), LDC, WORK ) * IF( FORWRD ) THEN II = II + NQ - I + 1 From b5797590362402f50f56ab7b4127baa4a7ba7498 Mon Sep 17 00:00:00 2001 From: Eduard Fedorenkov Date: Fri, 7 Jun 2024 15:41:39 +0700 Subject: [PATCH 12/16] small fix in larf1f and larf1l, #1011 --- SRC/clarf1l.f | 2 +- SRC/slarf1f.f | 13 +++++++------ SRC/slarf1l.f | 8 ++++---- 3 files changed, 12 insertions(+), 11 deletions(-) diff --git a/SRC/clarf1l.f b/SRC/clarf1l.f index 40dda403a7..3627f21c5e 100644 --- a/SRC/clarf1l.f +++ b/SRC/clarf1l.f @@ -244,7 +244,7 @@ SUBROUTINE CLARF1L( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) * w(1:lastc,1) := C(1:lastc,1:lastv-1) * v(1:lastv-1,1) * CALL CGEMV( 'No transpose', LASTC, LASTV - 1, ONE, C, - $ LDC, V, INCV, ZERO, WORK, 1 ) + $ LDC, V, INCV, ZERO, WORK, 1 ) * * w(1:lastc,1) += C(1:lastc,lastv) * v(lastv,1) * diff --git a/SRC/slarf1f.f b/SRC/slarf1f.f index daf43423f5..efbec9061b 100644 --- a/SRC/slarf1f.f +++ b/SRC/slarf1f.f @@ -202,7 +202,7 @@ SUBROUTINE SLARF1F( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) * w(1:lastc,1) := C(2:lastv,1:lastc)**T * v(2:lastv,1) * CALL SGEMV( 'Transpose', LASTV - 1, LASTC, ONE, C( 2, 1 ), - $ LDC, V( 1 + INCV ), INCV, ZERO, WORK, 1 ) + $ LDC, V( 1 + INCV ), INCV, ZERO, WORK, 1 ) * * w(1:lastc,1) += v(1,1) * C(1,1:lastc)**T * @@ -214,8 +214,8 @@ SUBROUTINE SLARF1F( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) * * C(2:lastv,1:lastc) += - tau * v(2:lastv,1) * w(1:lastc,1)**T * - CALL SGER( LASTV - 1, LASTC, -TAU, V( 1 + INCV ), INCV, WORK, - $ 1, C( 2, 1 ), LDC ) + CALL SGER( LASTV - 1, LASTC, -TAU, V( 1 + INCV ), INCV, + $ WORK, 1, C( 2, 1 ), LDC ) END IF ELSE * @@ -230,8 +230,9 @@ SUBROUTINE SLARF1F( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) * * w(1:lastc,1) := C(1:lastc,2:lastv) * v(2:lastv,1) * - CALL SGEMV( 'No transpose', LASTC, LASTV - 1, ONE, - $ C( 1, 2 ), LDC, V( 1 + INCV ), INCV, ZERO, WORK, 1 ) + CALL SGEMV( 'No transpose', LASTC, LASTV - 1, ONE, + $ C( 1, 2 ), LDC, V( 1 + INCV ), INCV, ZERO, + $ WORK, 1 ) * * w(1:lastc,1) += v(1,1) * C(1:lastc,1) * @@ -244,7 +245,7 @@ SUBROUTINE SLARF1F( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) * C(1:lastc,2:lastv) += - tau * w(1:lastc,1) * v(2:lastv)**T * CALL SGER( LASTC, LASTV - 1, -TAU, WORK, 1, - $ V( 1 + INCV ), INCV, C( 1, 2 ), LDC ) + $ V( 1 + INCV ), INCV, C( 1, 2 ), LDC ) END IF END IF RETURN diff --git a/SRC/slarf1l.f b/SRC/slarf1l.f index d7b0eb759b..60b7fe863d 100644 --- a/SRC/slarf1l.f +++ b/SRC/slarf1l.f @@ -204,7 +204,7 @@ SUBROUTINE SLARF1L( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) * w(1:lastc,1) := C(1:lastv-1,1:lastc)**T * v(1:lastv-1,1) * CALL SGEMV( 'Transpose', LASTV - 1, LASTC, ONE, C, LDC, - $ V, INCV, ZERO, WORK, 1 ) + $ V, INCV, ZERO, WORK, 1 ) * * w(1:lastc,1) += C(lastv,1:lastc)**T * v(lastv,1) * @@ -217,7 +217,7 @@ SUBROUTINE SLARF1L( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) * C(1:lastv-1,1:lastc) += - tau * v(1:lastv-1,1) * w(1:lastc,1)**T * CALL SGER( LASTV - 1, LASTC, -TAU, V, INCV, WORK, 1, C, - $ LDC) + $ LDC) END IF ELSE * @@ -233,7 +233,7 @@ SUBROUTINE SLARF1L( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) * w(1:lastc,1) := C(1:lastc,1:lastv-1) * v(1:lastv-1,1) * CALL SGEMV( 'No transpose', LASTC, LASTV - 1, ONE, C, - $ LDC, V, INCV, ZERO, WORK, 1 ) + $ LDC, V, INCV, ZERO, WORK, 1 ) * * w(1:lastc,1) += C(1:lastc,lastv) * v(lastv,1) * @@ -246,7 +246,7 @@ SUBROUTINE SLARF1L( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) * C(1:lastc,1:lastv-1) += - tau * w(1:lastc,1) * v(1:lastv-1)**T * CALL SGER( LASTC, LASTV - 1, -TAU, WORK, 1, V, - $ INCV, C, LDC ) + $ INCV, C, LDC ) END IF END IF RETURN From cbd638d9d02888c59d9c3218913c408ca55dd8d8 Mon Sep 17 00:00:00 2001 From: Eduard Fedorenkov Date: Fri, 7 Jun 2024 16:29:15 +0700 Subject: [PATCH 13/16] define larf1f and larf1l in lapack_64.h, #1011 --- SRC/lapack_64.h | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/SRC/lapack_64.h b/SRC/lapack_64.h index 8576805b2e..24e4fd148a 100644 --- a/SRC/lapack_64.h +++ b/SRC/lapack_64.h @@ -325,6 +325,8 @@ #define CLAR2V CLAR2V_64 #define CLARCM CLARCM_64 #define CLARF CLARF_64 +#define CLARF1F CLARF1F_64 +#define CLARF1L CLARF1L_64 #define CLARFB CLARFB_64 #define CLARFB_GETT CLARFB_GETT_64 #define CLARFG CLARFG_64 @@ -1384,6 +1386,8 @@ #define SLAR1V SLAR1V_64 #define SLAR2V SLAR2V_64 #define SLARF SLARF_64 +#define SLARF1F SLARF1F_64 +#define SLARF1L SLARF1L_64 #define SLARFB SLARFB_64 #define SLARFB_GETT SLARFB_GETT_64 #define SLARFG SLARFG_64 From ba27bf02d77f2fd53ad859fe1d3fee187c7cea4e Mon Sep 17 00:00:00 2001 From: Eduard Fedorenkov Date: Fri, 7 Jun 2024 16:45:55 +0700 Subject: [PATCH 14/16] small fix in routines to use larf1f and larf1l, #1011 --- SRC/cunbdb.f | 5 +++-- SRC/sorbdb.f | 4 ++-- 2 files changed, 5 insertions(+), 4 deletions(-) diff --git a/SRC/cunbdb.f b/SRC/cunbdb.f index 3401cb6983..f78397ef6f 100644 --- a/SRC/cunbdb.f +++ b/SRC/cunbdb.f @@ -544,8 +544,9 @@ SUBROUTINE CUNBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, CALL CLACGV( M-P-Q-I+1, X22(Q+I,P+I), LDX22 ) CALL CLARFGP( M-P-Q-I+1, X22(Q+I,P+I), X22(Q+I,P+I+1), $ LDX22, TAUQ2(P+I) ) - CALL CLARF1F( 'R', M-P-Q-I, M-P-Q-I+1, X22(Q+I,P+I), LDX22, - $ TAUQ2(P+I), X22(Q+I+1,P+I), LDX22, WORK ) + CALL CLARF1F( 'R', M-P-Q-I, M-P-Q-I+1, X22(Q+I,P+I), + $ LDX22, TAUQ2(P+I), X22(Q+I+1,P+I), LDX22, + $ WORK ) * CALL CLACGV( M-P-Q-I+1, X22(Q+I,P+I), LDX22 ) * diff --git a/SRC/sorbdb.f b/SRC/sorbdb.f index a401342e1c..7da1a44d77 100644 --- a/SRC/sorbdb.f +++ b/SRC/sorbdb.f @@ -639,8 +639,8 @@ SUBROUTINE SORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, IF( I .LT. Q ) THEN CALL SLARF1F( 'L', Q-I, P-I, X11(I+1,I), 1, TAUQ1(I), $ X11(I+1,I+1), LDX11, WORK ) - CALL SLARF1F( 'L', Q-I, M-P-I, X11(I+1,I), 1, TAUQ1(I), - $ X21(I+1,I+1), LDX21, WORK ) + CALL SLARF1F( 'L', Q-I, M-P-I, X11(I+1,I), 1, + $ TAUQ1(I), X21(I+1,I+1), LDX21, WORK ) END IF CALL SLARF1F( 'L', M-Q-I+1, P-I, X12(I,I), 1, TAUQ2(I), $ X12(I,I+1), LDX12, WORK ) From 690067c21809121432e7aa46852a7869404c21cf Mon Sep 17 00:00:00 2001 From: Eduard Fedorenkov Date: Tue, 11 Jun 2024 17:17:45 +0700 Subject: [PATCH 15/16] add firstv param in larf1l, #1011 --- SRC/clarf1l.f | 66 +++++++++++++++++++++++++-------------------------- SRC/slarf1l.f | 56 +++++++++++++++++++++---------------------- 2 files changed, 59 insertions(+), 63 deletions(-) diff --git a/SRC/clarf1l.f b/SRC/clarf1l.f index 3627f21c5e..fae094bb67 100644 --- a/SRC/clarf1l.f +++ b/SRC/clarf1l.f @@ -84,7 +84,7 @@ *> \param[in] INCV *> \verbatim *> INCV is INTEGER -*> The increment between elements of v. INCV <> 0. +*> The increment between elements of v. INCV > 0. *> \endverbatim *> *> \param[in] TAU @@ -149,7 +149,7 @@ SUBROUTINE CLARF1L( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) * .. * .. Local Scalars .. LOGICAL APPLYLEFT - INTEGER I, LASTV, LASTC + INTEGER I, J, LASTV, LASTC, FIRSTV * .. * .. External Subroutines .. EXTERNAL CGEMV, CGERC, CSCAL @@ -165,7 +165,7 @@ SUBROUTINE CLARF1L( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) * .. Executable Statements .. * APPLYLEFT = LSAME( SIDE, 'L' ) - LASTV = 1 + FIRSTV = 1 LASTC = 0 IF( TAU.NE.ZERO ) THEN ! Set up variables for scanning V. LASTV begins pointing to the end @@ -175,15 +175,11 @@ SUBROUTINE CLARF1L( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) ELSE LASTV = N END IF - IF( INCV.GT.0 ) THEN - I = 1 + (LASTV-1) * INCV - ELSE - I = 1 - END IF + I = 1 ! Look for the last non-zero row in V. - DO WHILE( LASTV.GT.1 .AND. V( I ).EQ.ZERO ) - LASTV = LASTV - 1 - I = I - INCV + DO WHILE( LASTV.GT.FIRSTV .AND. V( I ).EQ.ZERO ) + FIRSTV = FIRSTV + 1 + I = I + INCV END DO IF( APPLYLEFT ) THEN ! Scan for the last non-zero column in C(1:lastv,:). @@ -200,51 +196,53 @@ SUBROUTINE CLARF1L( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) * * Form H * C * - IF( LASTV.EQ.1 ) THEN + IF( LASTV.EQ.FIRSTV ) THEN * -* C(1,1:lastc) := ( 1 - tau ) * C(1,1:lastc) +* C(lastv,1:lastc) := ( 1 - tau ) * C(lastv,1:lastc) * - CALL CSCAL( LASTC, ONE - TAU, C, LDC ) + CALL CSCAL( LASTC, ONE - TAU, C( LASTV, 1 ), LDC ) ELSE * -* w(1:lastc,1) := C(1:lastv-1,1:lastc)**T * v(1:lastv-1,1) +* w(1:lastc,1) := C(firstv:lastv-1,1:lastc)**T * v(firstv:lastv-1,1) * - CALL CGEMV( 'Conjugate transpose', LASTV - 1, LASTC, - $ ONE, C, LDC, V, INCV, ZERO, WORK, 1 ) + CALL CGEMV( 'Conjugate transpose', LASTV - FIRSTV, LASTC, + $ ONE, C( FIRSTV, 1 ), LDC, V( I ), INCV, ZERO, + $ WORK, 1 ) * * w(1:lastc,1) += C(lastv,1:lastc)**H * v(lastv,1) * - DO I = 1, LASTC - WORK( I ) = WORK( I ) + CONJG( C( LASTV, I ) ) + DO J = 1, LASTC + WORK( J ) = WORK( J ) + CONJG( C( LASTV, J ) ) END DO * * C(lastv,1:lastc) += - tau * v(lastv,1) * w(1:lastc,1)**H * - DO I = 1, LASTC - C( LASTV, I ) = C( LASTV, I ) - $ - TAU * CONJG( WORK( I ) ) + DO J = 1, LASTC + C( LASTV, J ) = C( LASTV, J ) + $ - TAU * CONJG( WORK( J ) ) END DO * -* C(1:lastv-1,1:lastc) += - tau * v(1:lastv-1,1) * w(1:lastc,1)**H +* C(firstv:lastv-1,1:lastc) += - tau * v(firstv:lastv-1,1) * w(1:lastc,1)**H * - CALL CGERC( LASTV - 1, LASTC, -TAU, V, INCV, WORK, 1, C, - $ LDC) + CALL CGERC( LASTV - FIRSTV, LASTC, -TAU, V( I ), INCV, + $ WORK, 1, C( FIRSTV, 1 ), LDC) END IF ELSE * * Form C * H * - IF( LASTV.EQ.1 ) THEN + IF( LASTV.EQ.FIRSTV ) THEN * -* C(1:lastc,1) := ( 1 - tau ) * C(1:lastc,1) +* C(1:lastc,lastv) := ( 1 - tau ) * C(1:lastc,lastv) * - CALL CSCAL( LASTC, ONE - TAU, C, 1 ) + CALL CSCAL( LASTC, ONE - TAU, C( 1, LASTV ), 1 ) ELSE * -* w(1:lastc,1) := C(1:lastc,1:lastv-1) * v(1:lastv-1,1) +* w(1:lastc,1) := C(1:lastc,firstv:lastv-1) * v(firstv:lastv-1,1) * - CALL CGEMV( 'No transpose', LASTC, LASTV - 1, ONE, C, - $ LDC, V, INCV, ZERO, WORK, 1 ) + CALL CGEMV( 'No transpose', LASTC, LASTV - FIRSTV, ONE, + $ C( 1, FIRSTV ), LDC, V( I ), INCV, ZERO, + $ WORK, 1 ) * * w(1:lastc,1) += C(1:lastc,lastv) * v(lastv,1) * @@ -254,10 +252,10 @@ SUBROUTINE CLARF1L( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) * CALL CAXPY( LASTC, -TAU, WORK, 1, C( 1, LASTV ), 1 ) * -* C(1:lastc,1:lastv-1) += - tau * w(1:lastc,1) * v(1:lastv-1)**H +* C(1:lastc,firstv:lastv-1) += - tau * w(1:lastc,1) * v(firstv:lastv-1)**H * - CALL CGERC( LASTC, LASTV - 1, -TAU, WORK, 1, V, - $ INCV, C, LDC ) + CALL CGERC( LASTC, LASTV - FIRSTV, -TAU, WORK, 1, V( I ), + $ INCV, C( 1, FIRSTV ), LDC ) END IF END IF RETURN diff --git a/SRC/slarf1l.f b/SRC/slarf1l.f index 60b7fe863d..f4a3596006 100644 --- a/SRC/slarf1l.f +++ b/SRC/slarf1l.f @@ -82,7 +82,7 @@ *> \param[in] INCV *> \verbatim *> INCV is INTEGER -*> The increment between elements of v. INCV <> 0. +*> The increment between elements of v. INCV > 0. *> \endverbatim *> *> \param[in] TAU @@ -146,7 +146,7 @@ SUBROUTINE SLARF1L( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) * .. * .. Local Scalars .. LOGICAL APPLYLEFT - INTEGER I, LASTV, LASTC + INTEGER I, LASTV, LASTC, FIRSTV * .. * .. External Subroutines .. EXTERNAL SGEMV, SGER, SAXPY, SSCAL @@ -159,7 +159,7 @@ SUBROUTINE SLARF1L( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) * .. Executable Statements .. * APPLYLEFT = LSAME( SIDE, 'L' ) - LASTV = 1 + FIRSTV = 1 LASTC = 0 IF( TAU.NE.ZERO ) THEN ! Set up variables for scanning V. LASTV begins pointing to the end @@ -169,15 +169,11 @@ SUBROUTINE SLARF1L( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) ELSE LASTV = N END IF - IF( INCV.GT.0 ) THEN - I = 1 + (LASTV-1) * INCV - ELSE - I = 1 - END IF + I = 1 ! Look for the last non-zero row in V. - DO WHILE( LASTV.GT.1 .AND. V( I ).EQ.ZERO ) - LASTV = LASTV - 1 - I = I - INCV + DO WHILE( LASTV.GT.FIRSTV .AND. V( I ).EQ.ZERO ) + FIRSTV = FIRSTV + 1 + I = I + INCV END DO IF( APPLYLEFT ) THEN ! Scan for the last non-zero column in C(1:lastv,:). @@ -194,17 +190,18 @@ SUBROUTINE SLARF1L( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) * * Form H * C * - IF( LASTV.EQ.1 ) THEN + IF( LASTV.EQ.FIRSTV ) THEN * -* C(1,1:lastc) := ( 1 - tau ) * C(1,1:lastc) +* C(lastv,1:lastc) := ( 1 - tau ) * C(lastv,1:lastc) * - CALL SSCAL( LASTC, ONE - TAU, C, LDC ) + CALL SSCAL( LASTC, ONE - TAU, C( LASTV, 1 ), LDC ) ELSE * -* w(1:lastc,1) := C(1:lastv-1,1:lastc)**T * v(1:lastv-1,1) +* w(1:lastc,1) := C(firstv:lastv-1,1:lastc)**T * v(firstv:lastv-1,1) * - CALL SGEMV( 'Transpose', LASTV - 1, LASTC, ONE, C, LDC, - $ V, INCV, ZERO, WORK, 1 ) + CALL SGEMV( 'Transpose', LASTV - FIRSTV, LASTC, ONE, + $ C( FIRSTV, 1 ), LDC, V( I ), INCV, ZERO, + $ WORK, 1 ) * * w(1:lastc,1) += C(lastv,1:lastc)**T * v(lastv,1) * @@ -214,26 +211,27 @@ SUBROUTINE SLARF1L( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) * CALL SAXPY( LASTC, -TAU, WORK, 1, C( LASTV, 1 ), LDC ) * -* C(1:lastv-1,1:lastc) += - tau * v(1:lastv-1,1) * w(1:lastc,1)**T +* C(firstv:lastv-1,1:lastc) += - tau * v(firstv:lastv-1,1) * w(1:lastc,1)**T * - CALL SGER( LASTV - 1, LASTC, -TAU, V, INCV, WORK, 1, C, - $ LDC) + CALL SGER( LASTV - FIRSTV, LASTC, -TAU, V( I ), INCV, + $ WORK, 1, C( FIRSTV, 1 ), LDC) END IF ELSE * * Form C * H * - IF( LASTV.EQ.1 ) THEN + IF( LASTV.EQ.FIRSTV ) THEN * -* C(1:lastc,1) := ( 1 - tau ) * C(1:lastc,1) +* C(1:lastc,lastv) := ( 1 - tau ) * C(1:lastc,lastv) * - CALL SSCAL( LASTC, ONE - TAU, C, 1 ) + CALL SSCAL( LASTC, ONE - TAU, C( 1, LASTV ), 1 ) ELSE * -* w(1:lastc,1) := C(1:lastc,1:lastv-1) * v(1:lastv-1,1) +* w(1:lastc,1) := C(1:lastc,firstv:lastv-1) * v(firstv:lastv-1,1) * - CALL SGEMV( 'No transpose', LASTC, LASTV - 1, ONE, C, - $ LDC, V, INCV, ZERO, WORK, 1 ) + CALL SGEMV( 'No transpose', LASTC, LASTV - FIRSTV, ONE, + $ C( 1, FIRSTV ), LDC, V( I ), INCV, ZERO, + $ WORK, 1 ) * * w(1:lastc,1) += C(1:lastc,lastv) * v(lastv,1) * @@ -243,10 +241,10 @@ SUBROUTINE SLARF1L( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) * CALL SAXPY( LASTC, -TAU, WORK, 1, C( 1, LASTV ), 1 ) * -* C(1:lastc,1:lastv-1) += - tau * w(1:lastc,1) * v(1:lastv-1)**T +* C(1:lastc,firstv:lastv-1) += - tau * w(1:lastc,1) * v(firstv:lastv-1)**T * - CALL SGER( LASTC, LASTV - 1, -TAU, WORK, 1, V, - $ INCV, C, LDC ) + CALL SGER( LASTC, LASTV - FIRSTV, -TAU, WORK, 1, V( I ), + $ INCV, C( 1, FIRSTV ), LDC ) END IF END IF RETURN From c8b1a514cd0e749ce5a0ad9836b65f23519b2f88 Mon Sep 17 00:00:00 2001 From: Eduard Fedorenkov Date: Thu, 13 Jun 2024 15:31:25 +0700 Subject: [PATCH 16/16] code style small fixes, #1011 --- SRC/cgelq2.f | 3 +-- SRC/clarf1f.f | 6 +++--- SRC/clarf1l.f | 6 +++--- SRC/cunbdb.f | 18 ++++++------------ SRC/cunbdb2.f | 4 ++-- SRC/cunbdb3.f | 4 ++-- SRC/cunbdb4.f | 10 ++++------ SRC/cung2l.f | 3 +-- SRC/cunm2r.f | 3 +-- SRC/sgebd2.f | 6 ++---- SRC/sgehd2.f | 4 ---- SRC/sgelq2.f | 7 +------ SRC/sgeql2.f | 7 +------ SRC/sgeqr2.f | 4 ---- SRC/sgeqr2p.f | 4 ---- SRC/sgerq2.f | 4 ---- SRC/slarf1f.f | 6 +++--- SRC/slarf1l.f | 6 +++--- SRC/sopmtr.f | 7 +------ SRC/sorbdb.f | 42 ++++++++++++++---------------------------- SRC/sorbdb1.f | 13 ++++--------- SRC/sorbdb2.f | 7 +++---- SRC/sorbdb3.f | 10 ++-------- SRC/sorbdb4.f | 17 +++++++---------- SRC/sorg2l.f | 3 +-- SRC/sorgr2.f | 3 +-- SRC/sorm2l.f | 4 ---- SRC/sorm2r.f | 4 ---- SRC/sorml2.f | 4 ---- SRC/sormr2.f | 7 +------ 30 files changed, 67 insertions(+), 159 deletions(-) diff --git a/SRC/cgelq2.f b/SRC/cgelq2.f index 80f056e9be..6f702f3c13 100644 --- a/SRC/cgelq2.f +++ b/SRC/cgelq2.f @@ -180,8 +180,7 @@ SUBROUTINE CGELQ2( M, N, A, LDA, TAU, WORK, INFO ) * Apply H(i) to A(i+1:m,i:n) from the right * CALL CLARF1F( 'Right', M-I, N-I+1, A( I, I ), LDA, - $ TAU( I ), - $ A( I+1, I ), LDA, WORK ) + $ TAU( I ), A( I+1, I ), LDA, WORK ) END IF CALL CLACGV( N-I+1, A( I, I ), LDA ) 10 CONTINUE diff --git a/SRC/clarf1f.f b/SRC/clarf1f.f index 255f074e4f..c973dc0747 100644 --- a/SRC/clarf1f.f +++ b/SRC/clarf1f.f @@ -8,11 +8,11 @@ * *> \htmlonly *> Download CLARF1F + dependencies -*> +*> *> [TGZ] -*> +*> *> [ZIP] -*> +*> *> [TXT] *> \endhtmlonly * diff --git a/SRC/clarf1l.f b/SRC/clarf1l.f index fae094bb67..a911bf1138 100644 --- a/SRC/clarf1l.f +++ b/SRC/clarf1l.f @@ -8,11 +8,11 @@ * *> \htmlonly *> Download CLARF1L + dependencies -*> +*> *> [TGZ] -*> +*> *> [ZIP] -*> +*> *> [TXT] *> \endhtmlonly * diff --git a/SRC/cunbdb.f b/SRC/cunbdb.f index f78397ef6f..d366f516aa 100644 --- a/SRC/cunbdb.f +++ b/SRC/cunbdb.f @@ -485,16 +485,13 @@ SUBROUTINE CUNBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, * IF( I .LT. Q ) THEN CALL CLARF1F( 'R', P-I, Q-I, X11(I,I+1), LDX11, - $ TAUQ1(I), - $ X11(I+1,I+1), LDX11, WORK ) + $ TAUQ1(I), X11(I+1,I+1), LDX11, WORK ) CALL CLARF1F( 'R', M-P-I, Q-I, X11(I,I+1), LDX11, - $ TAUQ1(I), - $ X21(I+1,I+1), LDX21, WORK ) + $ TAUQ1(I), X21(I+1,I+1), LDX21, WORK ) END IF IF ( P .GT. I ) THEN CALL CLARF1F( 'R', P-I, M-Q-I+1, X12(I,I), LDX12, - $ TAUQ2(I), - $ X12(I+1,I), LDX12, WORK ) + $ TAUQ2(I), X12(I+1,I), LDX12, WORK ) END IF IF ( M-P .GT. I ) THEN CALL CLARF1F( 'R', M-P-I, M-Q-I+1, X12(I,I), LDX12, @@ -524,8 +521,7 @@ SUBROUTINE CUNBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, * IF ( P .GT. I ) THEN CALL CLARF1F( 'R', P-I, M-Q-I+1, X12(I,I), LDX12, - $ TAUQ2(I), - $ X12(I+1,I), LDX12, WORK ) + $ TAUQ2(I), X12(I+1,I), LDX12, WORK ) END IF IF( M-P-Q .GE. 1 ) $ CALL CLARF1F( 'R', M-P-Q, M-Q-I+1, X12(I,I), LDX12, @@ -596,8 +592,7 @@ SUBROUTINE CUNBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, CALL CLARF1F( 'R', Q-I, P-I+1, X11(I,I), LDX11, TAUP1(I), $ X11(I+1,I), LDX11, WORK ) CALL CLARF1F( 'R', M-Q-I+1, P-I+1, X11(I,I), LDX11, - $ TAUP1(I), - $ X12(I,I), LDX12, WORK ) + $ TAUP1(I), X12(I,I), LDX12, WORK ) CALL CLARF1F( 'R', Q-I, M-P-I+1, X21(I,I), LDX21, $ TAUP2(I), X21(I+1,I), LDX21, WORK ) CALL CLARF1F( 'R', M-Q-I+1, M-P-I+1, X21(I,I), LDX21, @@ -638,8 +633,7 @@ SUBROUTINE CUNBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, $ WORK ) END IF CALL CLARF1F( 'L', M-Q-I+1, P-I, X12(I,I), 1, - $ CONJG(TAUQ2(I)), - $ X12(I,I+1), LDX12, WORK ) + $ CONJG(TAUQ2(I)), X12(I,I+1), LDX12, WORK ) IF ( M-P .GT. I ) THEN CALL CLARF1F( 'L', M-Q-I+1, M-P-I, X12(I,I), 1, diff --git a/SRC/cunbdb2.f b/SRC/cunbdb2.f index e9416679ec..b4ef0e83dc 100644 --- a/SRC/cunbdb2.f +++ b/SRC/cunbdb2.f @@ -309,8 +309,8 @@ SUBROUTINE CUNBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, C = COS( PHI(I) ) S = SIN( PHI(I) ) CALL CLARF1F( 'L', P-I, Q-I, X11(I+1,I), 1, - $ CONJG(TAUP1(I)), - $ X11(I+1,I+1), LDX11, WORK(ILARF) ) + $ CONJG(TAUP1(I)), X11(I+1,I+1), LDX11, + $ WORK(ILARF) ) END IF CALL CLARF1F( 'L', M-P-I+1, Q-I, X21(I,I), 1, $ CONJG(TAUP2(I)), X21(I,I+1), LDX21, diff --git a/SRC/cunbdb3.f b/SRC/cunbdb3.f index 2425a565eb..579a4fc7b0 100644 --- a/SRC/cunbdb3.f +++ b/SRC/cunbdb3.f @@ -305,8 +305,8 @@ SUBROUTINE CUNBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, C = COS( PHI(I) ) S = SIN( PHI(I) ) CALL CLARF1F( 'L', M-P-I, Q-I, X21(I+1,I), 1, - $ CONJG(TAUP2(I)), - $ X21(I+1,I+1), LDX21, WORK(ILARF) ) + $ CONJG(TAUP2(I)), X21(I+1,I+1), LDX21, + $ WORK(ILARF) ) END IF CALL CLARF1F( 'L', P-I+1, Q-I, X11(I,I), 1, CONJG(TAUP1(I)), $ X11(I,I+1), LDX11, WORK(ILARF) ) diff --git a/SRC/cunbdb4.f b/SRC/cunbdb4.f index 65f2717c5d..74c658c668 100644 --- a/SRC/cunbdb4.f +++ b/SRC/cunbdb4.f @@ -310,11 +310,9 @@ SUBROUTINE CUNBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, C = COS( THETA(I) ) S = SIN( THETA(I) ) CALL CLARF1F( 'L', P, Q, PHANTOM(1), 1, CONJG(TAUP1(1)), - $ X11, - $ LDX11, WORK(ILARF) ) + $ X11, LDX11, WORK(ILARF) ) CALL CLARF1F( 'L', M-P, Q, PHANTOM(P+1), 1, - $ CONJG(TAUP2(1)), - $ X21, LDX21, WORK(ILARF) ) + $ CONJG(TAUP2(1)), X21, LDX21, WORK(ILARF) ) ELSE CALL CUNBDB5( P-I+1, M-P-I+1, Q-I+1, X11(I,I-1), 1, $ X21(I,I-1), 1, X11(I,I), LDX11, X21(I,I), @@ -372,8 +370,8 @@ SUBROUTINE CUNBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, $ LDX21, $ TAUQ1(I) ) CALL CLARF1F( 'R', Q-I, Q-I+1, X21(M-Q+I-P,I), LDX21, - $ TAUQ1(I), - $ X21(M-Q+I-P+1,I), LDX21, WORK(ILARF) ) + $ TAUQ1(I), X21(M-Q+I-P+1,I), LDX21, + $ WORK(ILARF) ) CALL CLACGV( Q-I+1, X21(M-Q+I-P,I), LDX21 ) END DO * diff --git a/SRC/cung2l.f b/SRC/cung2l.f index 10536022c8..c7351591b6 100644 --- a/SRC/cung2l.f +++ b/SRC/cung2l.f @@ -179,8 +179,7 @@ SUBROUTINE CUNG2L( M, N, K, A, LDA, TAU, WORK, INFO ) * A( M-N+II, II ) = ONE CALL CLARF1L( 'Left', M-N+II, II-1, A( 1, II ), 1, TAU( I ), - $ A, - $ LDA, WORK ) + $ A, LDA, WORK ) CALL CSCAL( M-N+II-1, -TAU( I ), A( 1, II ), 1 ) A( M-N+II, II ) = ONE - TAU( I ) * diff --git a/SRC/cunm2r.f b/SRC/cunm2r.f index 07238cd416..67cdc4369c 100644 --- a/SRC/cunm2r.f +++ b/SRC/cunm2r.f @@ -267,8 +267,7 @@ SUBROUTINE CUNM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, TAUI = CONJG( TAU( I ) ) END IF CALL CLARF1F( SIDE, MI, NI, A( I, I ), 1, TAUI, C( IC, JC ), - $ LDC, - $ WORK ) + $ LDC, WORK ) 10 CONTINUE RETURN * diff --git a/SRC/sgebd2.f b/SRC/sgebd2.f index c0ff242297..e6bf4a5a15 100644 --- a/SRC/sgebd2.f +++ b/SRC/sgebd2.f @@ -247,8 +247,7 @@ SUBROUTINE SGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO ) * IF( I.LT.N ) $ CALL SLARF1F( 'Left', M-I+1, N-I, A( I, I ), 1, - $ TAUQ( I ), - $ A( I, I+1 ), LDA, WORK ) + $ TAUQ( I ), A( I, I+1 ), LDA, WORK ) * IF( I.LT.N ) THEN * @@ -299,8 +298,7 @@ SUBROUTINE SGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO ) * Apply H(i) to A(i+1:m,i+1:n) from the left * CALL SLARF1F( 'Left', M-I, N-I, A( I+1, I ), 1, - $ TAUQ( I ), - $ A( I+1, I+1 ), LDA, WORK ) + $ TAUQ( I ), A( I+1, I+1 ), LDA, WORK ) ELSE TAUQ( I ) = ZERO END IF diff --git a/SRC/sgehd2.f b/SRC/sgehd2.f index e513502130..7392dfdadf 100644 --- a/SRC/sgehd2.f +++ b/SRC/sgehd2.f @@ -160,10 +160,6 @@ SUBROUTINE SGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO ) * * ===================================================================== * -* .. Parameters .. - REAL ONE - PARAMETER ( ONE = 1.0E+0 ) -* .. * .. Local Scalars .. INTEGER I * .. diff --git a/SRC/sgelq2.f b/SRC/sgelq2.f index 3e431c3927..03995ce283 100644 --- a/SRC/sgelq2.f +++ b/SRC/sgelq2.f @@ -140,10 +140,6 @@ SUBROUTINE SGELQ2( M, N, A, LDA, TAU, WORK, INFO ) * * ===================================================================== * -* .. Parameters .. - REAL ONE - PARAMETER ( ONE = 1.0E+0 ) -* .. * .. Local Scalars .. INTEGER I, K * .. @@ -183,8 +179,7 @@ SUBROUTINE SGELQ2( M, N, A, LDA, TAU, WORK, INFO ) * Apply H(i) to A(i+1:m,i:n) from the right * CALL SLARF1F( 'Right', M-I, N-I+1, A( I, I ), LDA, - $ TAU( I ), - $ A( I+1, I ), LDA, WORK ) + $ TAU( I ), A( I+1, I ), LDA, WORK ) END IF 10 CONTINUE RETURN diff --git a/SRC/sgeql2.f b/SRC/sgeql2.f index ec58dc2269..0a66465607 100644 --- a/SRC/sgeql2.f +++ b/SRC/sgeql2.f @@ -134,10 +134,6 @@ SUBROUTINE SGEQL2( M, N, A, LDA, TAU, WORK, INFO ) * * ===================================================================== * -* .. Parameters .. - REAL ONE - PARAMETER ( ONE = 1.0E+0 ) -* .. * .. Local Scalars .. INTEGER I, K * .. @@ -177,8 +173,7 @@ SUBROUTINE SGEQL2( M, N, A, LDA, TAU, WORK, INFO ) * Apply H(i) to A(1:m-k+i,1:n-k+i-1) from the left * CALL SLARF1L( 'Left', M-K+I, N-K+I-1, A( 1, N-K+I ), 1, - $ TAU( I ), - $ A, LDA, WORK ) + $ TAU( I ), A, LDA, WORK ) 10 CONTINUE RETURN * diff --git a/SRC/sgeqr2.f b/SRC/sgeqr2.f index 1868b204c6..8a593dd65b 100644 --- a/SRC/sgeqr2.f +++ b/SRC/sgeqr2.f @@ -141,10 +141,6 @@ SUBROUTINE SGEQR2( M, N, A, LDA, TAU, WORK, INFO ) * * ===================================================================== * -* .. Parameters .. - REAL ONE - PARAMETER ( ONE = 1.0E+0 ) -* .. * .. Local Scalars .. INTEGER I, K * .. diff --git a/SRC/sgeqr2p.f b/SRC/sgeqr2p.f index 02fe30826d..e24ad01a1e 100644 --- a/SRC/sgeqr2p.f +++ b/SRC/sgeqr2p.f @@ -145,10 +145,6 @@ SUBROUTINE SGEQR2P( M, N, A, LDA, TAU, WORK, INFO ) * * ===================================================================== * -* .. Parameters .. - REAL ONE - PARAMETER ( ONE = 1.0E+0 ) -* .. * .. Local Scalars .. INTEGER I, K * .. diff --git a/SRC/sgerq2.f b/SRC/sgerq2.f index 036f979cb5..b997d1824e 100644 --- a/SRC/sgerq2.f +++ b/SRC/sgerq2.f @@ -134,10 +134,6 @@ SUBROUTINE SGERQ2( M, N, A, LDA, TAU, WORK, INFO ) * * ===================================================================== * -* .. Parameters .. - REAL ONE - PARAMETER ( ONE = 1.0E+0 ) -* .. * .. Local Scalars .. INTEGER I, K * .. diff --git a/SRC/slarf1f.f b/SRC/slarf1f.f index efbec9061b..c55a408047 100644 --- a/SRC/slarf1f.f +++ b/SRC/slarf1f.f @@ -8,11 +8,11 @@ * *> \htmlonly *> Download SLARF1F + dependencies -*> +*> *> [TGZ] -*> +*> *> [ZIP] -*> +*> *> [TXT] *> \endhtmlonly * diff --git a/SRC/slarf1l.f b/SRC/slarf1l.f index f4a3596006..2398963a91 100644 --- a/SRC/slarf1l.f +++ b/SRC/slarf1l.f @@ -9,11 +9,11 @@ * *> \htmlonly *> Download SLARF1L + dependencies -*> +*> *> [TGZ] -*> +*> *> [ZIP] -*> +*> *> [TXT] *> \endhtmlonly * diff --git a/SRC/sopmtr.f b/SRC/sopmtr.f index 14749c29d7..90c8ea0d0e 100644 --- a/SRC/sopmtr.f +++ b/SRC/sopmtr.f @@ -163,10 +163,6 @@ SUBROUTINE SOPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC, * * ===================================================================== * -* .. Parameters .. - REAL ONE - PARAMETER ( ONE = 1.0E+0 ) -* .. * .. Local Scalars .. LOGICAL FORWRD, LEFT, NOTRAN, UPPER INTEGER I, I1, I2, I3, IC, II, JC, MI, NI, NQ @@ -261,8 +257,7 @@ SUBROUTINE SOPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC, * Apply H(i) * CALL SLARF1L( SIDE, MI, NI, AP( II-I+1 ), 1, TAU( I ), C, - $ LDC, - $ WORK ) + $ LDC, WORK ) * IF( FORWRD ) THEN II = II + I + 2 diff --git a/SRC/sorbdb.f b/SRC/sorbdb.f index 7da1a44d77..b2f2eec4ca 100644 --- a/SRC/sorbdb.f +++ b/SRC/sorbdb.f @@ -307,8 +307,6 @@ SUBROUTINE SORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, * .. Parameters .. REAL REALONE PARAMETER ( REALONE = 1.0E0 ) - REAL ONE - PARAMETER ( ONE = 1.0E0 ) * .. * .. Local Scalars .. LOGICAL COLMAJOR, LQUERY @@ -436,18 +434,15 @@ SUBROUTINE SORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, END IF IF ( M-Q+1 .GT. I ) THEN CALL SLARF1F( 'L', P-I+1, M-Q-I+1, X11(I,I), 1, - $ TAUP1(I), - $ X12(I,I), LDX12, WORK ) + $ TAUP1(I), X12(I,I), LDX12, WORK ) END IF IF ( Q .GT. I ) THEN CALL SLARF1F( 'L', M-P-I+1, Q-I, X21(I,I), 1, - $ TAUP2(I), - $ X21(I,I+1), LDX21, WORK ) + $ TAUP2(I), X21(I,I+1), LDX21, WORK ) END IF IF ( M-Q+1 .GT. I ) THEN CALL SLARF1F( 'L', M-P-I+1, M-Q-I+1, X21(I,I), 1, - $ TAUP2(I), - $ X22(I,I), LDX22, WORK ) + $ TAUP2(I), X22(I,I), LDX22, WORK ) END IF * IF( I .LT. Q ) THEN @@ -488,16 +483,13 @@ SUBROUTINE SORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, * IF( I .LT. Q ) THEN CALL SLARF1F( 'R', P-I, Q-I, X11(I,I+1), LDX11, - $ TAUQ1(I), - $ X11(I+1,I+1), LDX11, WORK ) + $ TAUQ1(I), X11(I+1,I+1), LDX11, WORK ) CALL SLARF1F( 'R', M-P-I, Q-I, X11(I,I+1), LDX11, - $ TAUQ1(I), - $ X21(I+1,I+1), LDX21, WORK ) + $ TAUQ1(I), X21(I+1,I+1), LDX21, WORK ) END IF IF ( P .GT. I ) THEN CALL SLARF1F( 'R', P-I, M-Q-I+1, X12(I,I), LDX12, - $ TAUQ2(I), - $ X12(I+1,I), LDX12, WORK ) + $ TAUQ2(I), X12(I+1,I), LDX12, WORK ) END IF IF ( M-P .GT. I ) THEN CALL SLARF1F( 'R', M-P-I, M-Q-I+1, X12(I,I), LDX12, @@ -521,8 +513,7 @@ SUBROUTINE SORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, * IF ( P .GT. I ) THEN CALL SLARF1F( 'R', P-I, M-Q-I+1, X12(I,I), LDX12, - $ TAUQ2(I), - $ X12(I+1,I), LDX12, WORK ) + $ TAUQ2(I), X12(I+1,I), LDX12, WORK ) END IF IF( M-P-Q .GE. 1 ) $ CALL SLARF1F( 'R', M-P-Q, M-Q-I+1, X12(I,I), LDX12, @@ -589,8 +580,7 @@ SUBROUTINE SORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, * IF ( Q .GT. I ) THEN CALL SLARF1F( 'R', Q-I, P-I+1, X11(I,I), LDX11, - $ TAUP1(I), - $ X11(I+1,I), LDX11, WORK ) + $ TAUP1(I), X11(I+1,I), LDX11, WORK ) END IF IF ( M-Q+1 .GT. I ) THEN CALL SLARF1F( 'R', M-Q-I+1, P-I+1, X11(I,I), LDX11, @@ -598,8 +588,7 @@ SUBROUTINE SORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, END IF IF ( Q .GT. I ) THEN CALL SLARF1F( 'R', Q-I, M-P-I+1, X21(I,I), LDX21, - $ TAUP2(I), - $ X21(I+1,I), LDX21, WORK ) + $ TAUP2(I), X21(I+1,I), LDX21, WORK ) END IF IF ( M-Q+1 .GT. I ) THEN CALL SLARF1F( 'R', M-Q-I+1, M-P-I+1, X21(I,I), LDX21, @@ -646,8 +635,7 @@ SUBROUTINE SORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, $ X12(I,I+1), LDX12, WORK ) IF ( M-P-I .GT. 0 ) THEN CALL SLARF1F( 'L', M-Q-I+1, M-P-I, X12(I,I), 1, - $ TAUQ2(I), - $ X22(I,I+1), LDX22, WORK ) + $ TAUQ2(I), X22(I,I+1), LDX22, WORK ) END IF * END DO @@ -662,13 +650,11 @@ SUBROUTINE SORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, * IF ( P .GT. I ) THEN CALL SLARF1F( 'L', M-Q-I+1, P-I, X12(I,I), 1, - $ TAUQ2(I), - $ X12(I,I+1), LDX12, WORK ) + $ TAUQ2(I), X12(I,I+1), LDX12, WORK ) END IF IF( M-P-Q .GE. 1 ) $ CALL SLARF1F( 'L', M-Q-I+1, M-P-Q, X12(I,I), 1, - $ TAUQ2(I), - $ X22(I,Q+1), LDX22, WORK ) + $ TAUQ2(I), X22(I,Q+1), LDX22, WORK ) * END DO * @@ -686,8 +672,8 @@ SUBROUTINE SORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, $ 1, $ TAUQ2(P+I) ) CALL SLARF1F( 'L', M-P-Q-I+1, M-P-Q-I, X22(P+I,Q+I), - $ 1, TAUQ2(P+I), X22(P+I,Q+I+1), - $ LDX22, WORK ) + $ 1, TAUQ2(P+I), X22(P+I,Q+I+1), LDX22, + $ WORK ) END IF * * diff --git a/SRC/sorbdb1.f b/SRC/sorbdb1.f index 1ce1bc8a6d..1304efe104 100644 --- a/SRC/sorbdb1.f +++ b/SRC/sorbdb1.f @@ -217,10 +217,6 @@ SUBROUTINE SORBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, * * ==================================================================== * -* .. Parameters .. - REAL ONE - PARAMETER ( ONE = 1.0E0 ) -* .. * .. Local Scalars .. REAL C, S INTEGER CHILDINFO, I, ILARF, IORBDB5, LLARF, LORBDB5, @@ -288,10 +284,9 @@ SUBROUTINE SORBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, C = COS( THETA(I) ) S = SIN( THETA(I) ) CALL SLARF1F( 'L', P-I+1, Q-I, X11(I,I), 1, TAUP1(I), X11(I, - $ I+1), - $ LDX11, WORK(ILARF) ) + $ I+1), LDX11, WORK(ILARF) ) CALL SLARF1F( 'L', M-P-I+1, Q-I, X21(I,I), 1, TAUP2(I), - $ X21(I,I+1), LDX21, WORK(ILARF) ) + $ X21(I,I+1), LDX21, WORK(ILARF) ) * IF( I .LT. Q ) THEN CALL SROT( Q-I, X11(I,I+1), LDX11, X21(I,I+1), LDX21, C, @@ -302,8 +297,8 @@ SUBROUTINE SORBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, CALL SLARF1F( 'R', P-I, Q-I, X21(I,I+1), LDX21, TAUQ1(I), $ X11(I+1,I+1), LDX11, WORK(ILARF) ) CALL SLARF1F( 'R', M-P-I, Q-I, X21(I,I+1), LDX21, - $ TAUQ1(I), - $ X21(I+1,I+1), LDX21, WORK(ILARF) ) + $ TAUQ1(I), X21(I+1,I+1), LDX21, + $ WORK(ILARF) ) C = SQRT( SNRM2( P-I, X11(I+1,I+1), 1 )**2 $ + SNRM2( M-P-I, X21(I+1,I+1), 1 )**2 ) PHI(I) = ATAN2( S, C ) diff --git a/SRC/sorbdb2.f b/SRC/sorbdb2.f index c785305c8c..b35a83b60e 100644 --- a/SRC/sorbdb2.f +++ b/SRC/sorbdb2.f @@ -216,8 +216,8 @@ SUBROUTINE SORBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, * ==================================================================== * * .. Parameters .. - REAL NEGONE, ONE - PARAMETER ( NEGONE = -1.0E0, ONE = 1.0E0 ) + REAL NEGONE + PARAMETER ( NEGONE = -1.0E0 ) * .. * .. Local Scalars .. REAL C, S @@ -289,8 +289,7 @@ SUBROUTINE SORBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, CALL SLARF1F( 'R', P-I, Q-I+1, X11(I,I), LDX11, TAUQ1(I), $ X11(I+1,I), LDX11, WORK(ILARF) ) CALL SLARF1F( 'R', M-P-I+1, Q-I+1, X11(I,I), LDX11, - $ TAUQ1(I), - $ X21(I,I), LDX21, WORK(ILARF) ) + $ TAUQ1(I), X21(I,I), LDX21, WORK(ILARF) ) S = SQRT( SNRM2( P-I, X11(I+1,I), 1 )**2 $ + SNRM2( M-P-I+1, X21(I,I), 1 )**2 ) THETA(I) = ATAN2( S, C ) diff --git a/SRC/sorbdb3.f b/SRC/sorbdb3.f index d064723e6a..4fa7231d1d 100644 --- a/SRC/sorbdb3.f +++ b/SRC/sorbdb3.f @@ -216,10 +216,6 @@ SUBROUTINE SORBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, * * ==================================================================== * -* .. Parameters .. - REAL ONE - PARAMETER ( ONE = 1.0E0 ) -* .. * .. Local Scalars .. REAL C, S INTEGER CHILDINFO, I, ILARF, IORBDB5, LLARF, LORBDB5, @@ -310,8 +306,7 @@ SUBROUTINE SORBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, $ X21(I+1,I+1), LDX21, WORK(ILARF) ) END IF CALL SLARF1F( 'L', P-I+1, Q-I, X11(I,I), 1, TAUP1(I), X11(I, - $ I+1), - $ LDX11, WORK(ILARF) ) + $ I+1), LDX11, WORK(ILARF) ) * END DO * @@ -320,8 +315,7 @@ SUBROUTINE SORBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, DO I = M-P + 1, Q CALL SLARFGP( P-I+1, X11(I,I), X11(I+1,I), 1, TAUP1(I) ) CALL SLARF1F( 'L', P-I+1, Q-I, X11(I,I), 1, TAUP1(I), X11(I, - $ I+1), - $ LDX11, WORK(ILARF) ) + $ I+1), LDX11, WORK(ILARF) ) END DO * RETURN diff --git a/SRC/sorbdb4.f b/SRC/sorbdb4.f index 0eb9edd658..a429d9d812 100644 --- a/SRC/sorbdb4.f +++ b/SRC/sorbdb4.f @@ -229,8 +229,8 @@ SUBROUTINE SORBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, * ==================================================================== * * .. Parameters .. - REAL NEGONE, ONE, ZERO - PARAMETER ( NEGONE = -1.0E0, ONE = 1.0E0, ZERO = 0.0E0 ) + REAL NEGONE, ZERO + PARAMETER ( NEGONE = -1.0E0, ZERO = 0.0E0 ) * .. * .. Local Scalars .. REAL C, S @@ -309,11 +309,9 @@ SUBROUTINE SORBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, C = COS( THETA(I) ) S = SIN( THETA(I) ) CALL SLARF1F( 'L', P, Q, PHANTOM(1), 1, TAUP1(1), X11, - $ LDX11, - $ WORK(ILARF) ) + $ LDX11, WORK(ILARF) ) CALL SLARF1F( 'L', M-P, Q, PHANTOM(P+1), 1, TAUP2(1), - $ X21, - $ LDX21, WORK(ILARF) ) + $ X21, LDX21, WORK(ILARF) ) ELSE CALL SORBDB5( P-I+1, M-P-I+1, Q-I+1, X11(I,I-1), 1, $ X21(I,I-1), 1, X11(I,I), LDX11, X21(I,I), @@ -329,8 +327,7 @@ SUBROUTINE SORBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, CALL SLARF1F( 'L', P-I+1, Q-I+1, X11(I,I-1), 1, TAUP1(I), $ X11(I,I), LDX11, WORK(ILARF) ) CALL SLARF1F( 'L', M-P-I+1, Q-I+1, X21(I,I-1), 1, - $ TAUP2(I), - $ X21(I,I), LDX21, WORK(ILARF) ) + $ TAUP2(I), X21(I,I), LDX21, WORK(ILARF) ) END IF * CALL SROT( Q-I+1, X11(I,I), LDX11, X21(I,I), LDX21, S, -C ) @@ -365,8 +362,8 @@ SUBROUTINE SORBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, $ LDX21, $ TAUQ1(I) ) CALL SLARF1F( 'R', Q-I, Q-I+1, X21(M-Q+I-P,I), LDX21, - $ TAUQ1(I), - $ X21(M-Q+I-P+1,I), LDX21, WORK(ILARF) ) + $ TAUQ1(I), X21(M-Q+I-P+1,I), LDX21, + $ WORK(ILARF) ) END DO * RETURN diff --git a/SRC/sorg2l.f b/SRC/sorg2l.f index 32bbbaabb9..7ac4a204bd 100644 --- a/SRC/sorg2l.f +++ b/SRC/sorg2l.f @@ -178,8 +178,7 @@ SUBROUTINE SORG2L( M, N, K, A, LDA, TAU, WORK, INFO ) * A( M-N+II, II ) = ONE CALL SLARF1L( 'Left', M-N+II, II-1, A( 1, II ), 1, TAU( I ), - $ A, - $ LDA, WORK ) + $ A, LDA, WORK ) CALL SSCAL( M-N+II-1, -TAU( I ), A( 1, II ), 1 ) A( M-N+II, II ) = ONE - TAU( I ) * diff --git a/SRC/sorgr2.f b/SRC/sorgr2.f index 3435d3586f..5ba985aca0 100644 --- a/SRC/sorgr2.f +++ b/SRC/sorgr2.f @@ -182,8 +182,7 @@ SUBROUTINE SORGR2( M, N, K, A, LDA, TAU, WORK, INFO ) * A( II, N-M+II ) = ONE CALL SLARF1L( 'Right', II-1, N-M+II, A( II, 1 ), LDA, - $ TAU( I ), - $ A, LDA, WORK ) + $ TAU( I ), A, LDA, WORK ) CALL SSCAL( N-M+II-1, -TAU( I ), A( II, 1 ), LDA ) A( II, N-M+II ) = ONE - TAU( I ) * diff --git a/SRC/sorm2l.f b/SRC/sorm2l.f index ff2e0b1c87..b4792d8a9f 100644 --- a/SRC/sorm2l.f +++ b/SRC/sorm2l.f @@ -171,10 +171,6 @@ SUBROUTINE SORM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, * * ===================================================================== * -* .. Parameters .. - REAL ONE - PARAMETER ( ONE = 1.0E+0 ) -* .. * .. Local Scalars .. LOGICAL LEFT, NOTRAN INTEGER I, I1, I2, I3, MI, NI, NQ diff --git a/SRC/sorm2r.f b/SRC/sorm2r.f index 360770a5bf..bdadcd8055 100644 --- a/SRC/sorm2r.f +++ b/SRC/sorm2r.f @@ -171,10 +171,6 @@ SUBROUTINE SORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, * * ===================================================================== * -* .. Parameters .. - REAL ONE - PARAMETER ( ONE = 1.0E+0 ) -* .. * .. Local Scalars .. LOGICAL LEFT, NOTRAN INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ diff --git a/SRC/sorml2.f b/SRC/sorml2.f index 7ebd0caf8a..c1e0c4a080 100644 --- a/SRC/sorml2.f +++ b/SRC/sorml2.f @@ -171,10 +171,6 @@ SUBROUTINE SORML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, * * ===================================================================== * -* .. Parameters .. - REAL ONE - PARAMETER ( ONE = 1.0E+0 ) -* .. * .. Local Scalars .. LOGICAL LEFT, NOTRAN INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ diff --git a/SRC/sormr2.f b/SRC/sormr2.f index e0e4f73311..256c8fd2fc 100644 --- a/SRC/sormr2.f +++ b/SRC/sormr2.f @@ -171,10 +171,6 @@ SUBROUTINE SORMR2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, * * ===================================================================== * -* .. Parameters .. - REAL ONE - PARAMETER ( ONE = 1.0E+0 ) -* .. * .. Local Scalars .. LOGICAL LEFT, NOTRAN INTEGER I, I1, I2, I3, MI, NI, NQ @@ -262,8 +258,7 @@ SUBROUTINE SORMR2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, * Apply H(i) * CALL SLARF1L( SIDE, MI, NI, A( I, 1 ), LDA, TAU( I ), C, - $ LDC, - $ WORK ) + $ LDC, WORK ) 10 CONTINUE RETURN *