diff --git a/SRC/CMakeLists.txt b/SRC/CMakeLists.txt index a2f396bae2..d9662db944 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 @@ -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 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 5662d2ab00..7fb2a5670d 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 \ @@ -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 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/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..6f702f3c13 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,15 @@ 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/clarf1f.f b/SRC/clarf1f.f new file mode 100644 index 0000000000..c973dc0747 --- /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 = 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(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 diff --git a/SRC/clarf1l.f b/SRC/clarf1l.f new file mode 100644 index 0000000000..a911bf1138 --- /dev/null +++ b/SRC/clarf1l.f @@ -0,0 +1,265 @@ +*> \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, J, LASTV, LASTC, FIRSTV +* .. +* .. 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' ) + FIRSTV = 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 + I = 1 +! Look for the last non-zero row in V. + 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,:). + 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.FIRSTV ) THEN +* +* C(lastv,1:lastc) := ( 1 - tau ) * C(lastv,1:lastc) +* + CALL CSCAL( LASTC, ONE - TAU, C( LASTV, 1 ), LDC ) + ELSE +* +* w(1:lastc,1) := C(firstv:lastv-1,1:lastc)**T * v(firstv:lastv-1,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 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 J = 1, LASTC + C( LASTV, J ) = C( LASTV, J ) + $ - TAU * CONJG( WORK( J ) ) + END DO +* +* C(firstv:lastv-1,1:lastc) += - tau * v(firstv:lastv-1,1) * w(1:lastc,1)**H +* + CALL CGERC( LASTV - FIRSTV, LASTC, -TAU, V( I ), INCV, + $ WORK, 1, C( FIRSTV, 1 ), LDC) + END IF + ELSE +* +* Form C * H +* + IF( LASTV.EQ.FIRSTV ) THEN +* +* C(1:lastc,lastv) := ( 1 - tau ) * C(1:lastc,lastv) +* + CALL CSCAL( LASTC, ONE - TAU, C( 1, LASTV ), 1 ) + ELSE +* +* w(1:lastc,1) := C(1:lastc,firstv:lastv-1) * v(firstv:lastv-1,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) +* + 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,firstv:lastv-1) += - tau * w(1:lastc,1) * v(firstv:lastv-1)**H +* + CALL CGERC( LASTC, LASTV - FIRSTV, -TAU, WORK, 1, V( I ), + $ INCV, C( 1, FIRSTV ), LDC ) + END IF + END IF + RETURN +* +* End of CLARF1L +* + END diff --git a/SRC/cunbdb.f b/SRC/cunbdb.f index 7abfb07d71..d366f516aa 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,20 @@ 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 +518,14 @@ 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 +540,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) ) - 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 +581,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 +588,15 @@ 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 +620,25 @@ 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 +650,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 +671,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..b4ef0e83dc 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..579a4fc7b0 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..74c658c668 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,10 @@ 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 +325,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 +355,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 +369,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..c7351591b6 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,8 @@ 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 0682381be3..67cdc4369c 100644 --- a/SRC/cunm2r.f +++ b/SRC/cunm2r.f @@ -171,21 +171,17 @@ 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 - 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 +266,8 @@ 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 * 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 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 diff --git a/SRC/sgebd2.f b/SRC/sgebd2.f index 978ec9f369..e6bf4a5a15 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,12 @@ 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 +257,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 +278,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 +294,11 @@ 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..7392dfdadf 100644 --- a/SRC/sgehd2.f +++ b/SRC/sgehd2.f @@ -160,16 +160,11 @@ SUBROUTINE SGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO ) * * ===================================================================== * -* .. Parameters .. - REAL ONE - PARAMETER ( ONE = 1.0E+0 ) -* .. * .. Local Scalars .. INTEGER I - REAL AII * .. * .. External Subroutines .. - EXTERNAL SLARF, SLARFG, XERBLA + EXTERNAL SLARF1F, SLARFG, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN @@ -199,20 +194,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..03995ce283 100644 --- a/SRC/sgelq2.f +++ b/SRC/sgelq2.f @@ -140,16 +140,11 @@ SUBROUTINE SGELQ2( M, N, A, LDA, TAU, WORK, INFO ) * * ===================================================================== * -* .. Parameters .. - REAL ONE - PARAMETER ( ONE = 1.0E+0 ) -* .. * .. Local Scalars .. INTEGER I, K - REAL AII * .. * .. External Subroutines .. - EXTERNAL SLARF, SLARFG, XERBLA + EXTERNAL SLARF1F, SLARFG, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN @@ -183,12 +178,8 @@ 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..0a66465607 100644 --- a/SRC/sgeql2.f +++ b/SRC/sgeql2.f @@ -134,16 +134,11 @@ SUBROUTINE SGEQL2( M, N, A, LDA, TAU, WORK, INFO ) * * ===================================================================== * -* .. Parameters .. - REAL ONE - PARAMETER ( ONE = 1.0E+0 ) -* .. * .. Local Scalars .. INTEGER I, K - REAL AII * .. * .. External Subroutines .. - EXTERNAL SLARF, SLARFG, XERBLA + EXTERNAL SLARF1L, SLARFG, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN @@ -177,12 +172,8 @@ 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..8a593dd65b 100644 --- a/SRC/sgeqr2.f +++ b/SRC/sgeqr2.f @@ -141,16 +141,11 @@ SUBROUTINE SGEQR2( M, N, A, LDA, TAU, WORK, INFO ) * * ===================================================================== * -* .. Parameters .. - REAL ONE - PARAMETER ( ONE = 1.0E+0 ) -* .. * .. Local Scalars .. INTEGER I, K - REAL AII * .. * .. External Subroutines .. - EXTERNAL SLARF, SLARFG, XERBLA + EXTERNAL SLARF1F, SLARFG, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN @@ -184,11 +179,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..e24ad01a1e 100644 --- a/SRC/sgeqr2p.f +++ b/SRC/sgeqr2p.f @@ -145,16 +145,11 @@ SUBROUTINE SGEQR2P( M, N, A, LDA, TAU, WORK, INFO ) * * ===================================================================== * -* .. Parameters .. - REAL ONE - PARAMETER ( ONE = 1.0E+0 ) -* .. * .. Local Scalars .. INTEGER I, K - REAL AII * .. * .. External Subroutines .. - EXTERNAL SLARF, SLARFGP, XERBLA + EXTERNAL SLARF1F, SLARFGP, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN @@ -188,11 +183,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..b997d1824e 100644 --- a/SRC/sgerq2.f +++ b/SRC/sgerq2.f @@ -134,16 +134,11 @@ SUBROUTINE SGERQ2( M, N, A, LDA, TAU, WORK, INFO ) * * ===================================================================== * -* .. Parameters .. - REAL ONE - PARAMETER ( ONE = 1.0E+0 ) -* .. * .. Local Scalars .. INTEGER I, K - REAL AII * .. * .. External Subroutines .. - EXTERNAL SLARF, SLARFG, XERBLA + EXTERNAL SLARF1L, SLARFG, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN @@ -177,11 +172,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/slarf1f.f b/SRC/slarf1f.f new file mode 100644 index 0000000000..c55a408047 --- /dev/null +++ b/SRC/slarf1f.f @@ -0,0 +1,255 @@ +*> \brief \b SLARF1F 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 SLARF1F + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE SLARF1F( 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 +*> +*> 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 +*> +*> 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 +* +* 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 larf1f +* +* ===================================================================== + SUBROUTINE SLARF1F( 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 = 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 = 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 ) 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(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 ) +* +* w(1:lastc,1) += v(1,1) * C(1,1:lastc)**T +* + CALL SAXPY( LASTC, ONE, C, LDC, WORK, 1 ) +* +* C(1, 1:lastc) += - tau * v(1,1) * w(1:lastc,1)**T +* + CALL SAXPY( LASTC, -TAU, WORK, 1, C, LDC ) +* +* 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 ) + 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,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 ) +* +* w(1:lastc,1) += v(1,1) * C(1:lastc,1) +* + CALL SAXPY( LASTC, ONE, C, 1, WORK, 1 ) +* +* C(1:lastc,1) += - tau * v(1,1) * w(1:lastc,1) +* + CALL SAXPY( LASTC, -TAU, WORK, 1, C, 1 ) +* +* 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 ) + END IF + END IF + RETURN +* +* End of SLARF1F +* + END diff --git a/SRC/slarf1l.f b/SRC/slarf1l.f new file mode 100644 index 0000000000..2398963a91 --- /dev/null +++ b/SRC/slarf1l.f @@ -0,0 +1,254 @@ +*> \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, FIRSTV +* .. +* .. External Subroutines .. + EXTERNAL SGEMV, SGER, SAXPY, SSCAL +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILASLR, ILASLC + EXTERNAL LSAME, ILASLR, ILASLC +* .. +* .. Executable Statements .. +* + APPLYLEFT = LSAME( SIDE, 'L' ) + FIRSTV = 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 + I = 1 +! Look for the last non-zero row in V. + 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,:). + 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 ) THEN + RETURN + END IF + IF( APPLYLEFT ) THEN +* +* Form H * C +* + IF( LASTV.EQ.FIRSTV ) THEN +* +* C(lastv,1:lastc) := ( 1 - tau ) * C(lastv,1:lastc) +* + CALL SSCAL( LASTC, ONE - TAU, C( LASTV, 1 ), LDC ) + ELSE +* +* w(1:lastc,1) := C(firstv:lastv-1,1:lastc)**T * v(firstv:lastv-1,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) +* + 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(firstv:lastv-1,1:lastc) += - tau * v(firstv:lastv-1,1) * w(1:lastc,1)**T +* + CALL SGER( LASTV - FIRSTV, LASTC, -TAU, V( I ), INCV, + $ WORK, 1, C( FIRSTV, 1 ), LDC) + END IF + ELSE +* +* Form C * H +* + IF( LASTV.EQ.FIRSTV ) THEN +* +* C(1:lastc,lastv) := ( 1 - tau ) * C(1:lastc,lastv) +* + CALL SSCAL( LASTC, ONE - TAU, C( 1, LASTV ), 1 ) + ELSE +* +* w(1:lastc,1) := C(1:lastc,firstv:lastv-1) * v(firstv:lastv-1,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) +* + 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,firstv:lastv-1) += - tau * w(1:lastc,1) * v(firstv:lastv-1)**T +* + CALL SGER( LASTC, LASTV - FIRSTV, -TAU, WORK, 1, V( I ), + $ INCV, C( 1, FIRSTV ), LDC ) + END IF + END IF + RETURN +* +* End of SLARF1L +* + END diff --git a/SRC/sopmtr.f b/SRC/sopmtr.f index e8542f3473..90c8ea0d0e 100644 --- a/SRC/sopmtr.f +++ b/SRC/sopmtr.f @@ -163,21 +163,16 @@ 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 - REAL AII * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. - EXTERNAL SLARF, XERBLA + EXTERNAL SLARF1F, SLARF1L, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX @@ -261,12 +256,8 @@ 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 +293,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 +309,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..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 @@ -316,7 +314,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 +420,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 +427,22 @@ 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 +470,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 +480,20 @@ 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 +510,14 @@ 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 +533,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 +570,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 +577,22 @@ 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 +616,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 +624,18 @@ 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 +647,14 @@ 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 +667,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..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, @@ -228,7 +224,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,13 +283,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), - $ X21(I,I+1), LDX21, WORK(ILARF) ) + 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 CALL SROT( Q-I, X11(I,I+1), LDX11, X21(I,I+1), LDX21, C, @@ -301,11 +294,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..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 @@ -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,10 @@ 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 +304,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 +316,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..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, @@ -227,7 +223,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 +284,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 +302,11 @@ 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 +314,8 @@ 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..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 @@ -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,10 @@ 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 +324,19 @@ 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 +349,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 +361,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..7ac4a204bd 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,8 @@ 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..5ba985aca0 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,8 @@ 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/sorm2l.f b/SRC/sorm2l.f index bdd883c6c7..b4792d8a9f 100644 --- a/SRC/sorm2l.f +++ b/SRC/sorm2l.f @@ -171,21 +171,16 @@ 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 - REAL AII * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. - EXTERNAL SLARF, XERBLA + EXTERNAL SLARF1L, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX @@ -262,11 +257,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..bdadcd8055 100644 --- a/SRC/sorm2r.f +++ b/SRC/sorm2r.f @@ -171,21 +171,16 @@ 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 - REAL AII * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. - EXTERNAL SLARF, XERBLA + EXTERNAL SLARF1F, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX @@ -266,12 +261,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 * diff --git a/SRC/sorml2.f b/SRC/sorml2.f index 27f970fcdb..c1e0c4a080 100644 --- a/SRC/sorml2.f +++ b/SRC/sorml2.f @@ -171,21 +171,16 @@ 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 - REAL AII * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. - EXTERNAL SLARF, XERBLA + EXTERNAL SLARF1F, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX @@ -266,11 +261,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..256c8fd2fc 100644 --- a/SRC/sormr2.f +++ b/SRC/sormr2.f @@ -171,21 +171,16 @@ 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 - REAL AII * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. - EXTERNAL SLARF, XERBLA + EXTERNAL SLARF1L, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX @@ -262,11 +257,8 @@ 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 *