Skip to content

Commit

Permalink
Merge pull request Reference-LAPACK#1019 from EduardFedorenkov/1011-a…
Browse files Browse the repository at this point in the history 
…dd-larf1f-and-larf1l-in-lapack

develop DLARF1F and implement in ORM2R, Reference-LAPACK#1011
  • Loading branch information
@langou
langou committed Jun 19, 2024
2 parents 2121711 + c8b1a51 commit 256c836
Show file tree
Hide file tree
Showing 59 changed files with 1,463 additions and 730 deletions.
4 changes: 2 additions & 2 deletions SRC/CMakeLists.txt
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down
4 changes: 2 additions & 2 deletions SRC/Makefile
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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 \
Expand Down Expand Up @@ -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 \
Expand Down
30 changes: 13 additions & 17 deletions SRC/cgebd2.f
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand All @@ -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
Expand All @@ -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 )
*
Expand All @@ -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
Expand Down
20 changes: 6 additions & 14 deletions SRC/cgehd2.f
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down
17 changes: 4 additions & 13 deletions SRC/cgelq2.f
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down
17 changes: 5 additions & 12 deletions SRC/cgeql2.f
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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
*
Expand Down
4 changes: 2 additions & 2 deletions SRC/cgeqp3rk.f
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
*
Expand All @@ -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
Expand Down
14 changes: 3 additions & 11 deletions SRC/cgeqr2.f
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down
14 changes: 3 additions & 11 deletions SRC/cgeqr2p.f
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down
16 changes: 4 additions & 12 deletions SRC/cgerq2.f
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down
Loading

0 comments on commit 256c836

Please sign in to comment.