Skip to content

Implementation of dorm2r and dlarf1f #1020

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Merged
merged 29 commits into from
Jun 20, 2024
+1,464 −514
Merged

Implementation of dorm2r and dlarf1f #1020

Show file tree
Hide file tree
Changes from 1 commit
Commits
Show all changes
29 commits
Select commit Hold shift + click to select a range
db65b31
initial skeleton with tests ran
jprhyne May 15, 2024
2ec963d
initial skeleton with tests ran
jprhyne May 15, 2024
fb5dc39
current state of testing implementation
jprhyne May 16, 2024
4c8684d
current state of testing implementation
jprhyne May 16, 2024
af491a4
fixed dlarf1f and dorm2r implementation
jprhyne May 28, 2024
559a7e9
fixed dlarf1f and dorm2r implementation
jprhyne May 28, 2024
3267d41
small change for tau
jprhyne May 29, 2024
648d221
updated check for if we are a trivial case from m/n=1 to lastv=1
jprhyne May 30, 2024
2a87758
updated CMakeLists and added dlarf1l.f
jprhyne May 30, 2024
0be01da
implementing into dorm2l.f
jprhyne May 31, 2024
2d8314f
updating double precision routines to use dlarf1f and dlarf1l. Still …
jprhyne Jun 3, 2024
491c0cf
updating zlarf1f.f
jprhyne Jun 4, 2024
15ec332
updating comment on zlarf1f.f
jprhyne Jun 4, 2024
468cb59
alternative formulation more similar to dlarf1f.f
jprhyne Jun 4, 2024
7708f1e
update dlarf1f.f and zlarf1f.f to not reference v(1)
jprhyne Jun 6, 2024
741907c
updating dlarf1f and dlarf1l to fix a bug found within dorg2l
jprhyne Jun 10, 2024
c744ebe
updating dlarf1l to use firstv scanner properly
jprhyne Jun 12, 2024
b69186b
updating dlarf1l.f
jprhyne Jun 12, 2024
35b3758
implement zlarf1l and use it in relevant routines. TODO: update comme…
jprhyne Jun 14, 2024
d219017
implement zlarf1l and use it in relevant routines. TODO: update comme…
jprhyne Jun 14, 2024
35d6a7b
updating documentation, using xLARF1y where applicable, and removing …
jprhyne Jun 15, 2024
48fbcb1
updating documentation, using xLARF1y where applicable, and removing …
jprhyne Jun 15, 2024
63461c1
updating documentation, using xLARF1y where applicable, and removing …
jprhyne Jun 15, 2024
12075f5
updating documentation, using xLARF1y where applicable, and removing …
jprhyne Jun 15, 2024
b564666
adding macro to lapack_64.h
jprhyne Jun 18, 2024
4a5139e
adding macro to lapack_64.h
jprhyne Jun 18, 2024
5953353
Merge branch 'Reference-LAPACK:master' into orm2r
jprhyne Jun 19, 2024
57b267c
fixing compilation errors due to not checking for lastc=0
jprhyne Jun 20, 2024
9a51a35
fixing compilation errors in test suite
jprhyne Jun 20, 2024
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
Prev Previous commit
fixing compilation errors in test suite
  • Loading branch information
@jprhyne
jprhyne committed Jun 20, 2024
commit 9a51a35c8b3b7bd99cfa3919c4238df37e0013b5
28 changes: 13 additions & 15 deletions SRC/dorbdb.f
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -440,13 +440,12 @@ SUBROUTINE DORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12,
$ X12(I,I), LDX12, WORK )
END IF
IF ( Q .GT. I ) THEN
CALL DLARF1F( 'L', M-P-I+1, Q-I, X21(I,I), 1, TAUP2(I),
$ X21(I,I+1), LDX21, WORK )
CALL DLARF1F( '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 DLARF1F( 'L', M-P-I+1, M-Q-I+1, X21(I,I), 1,
$ TAUP2(I),
$ X22(I,I), LDX22, WORK )
$ TAUP2(I), X22(I,I), LDX22, WORK )
END IF
*
IF( I .LT. Q ) THEN
Expand Down Expand Up @@ -638,15 +637,14 @@ SUBROUTINE DORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12,
IF( I .LT. Q ) THEN
CALL DLARF1F( 'L', Q-I, P-I, X11(I+1,I), 1, TAUQ1(I),
$ X11(I+1,I+1), LDX11, WORK )
CALL DLARF1F( 'L', Q-I, M-P-I, X11(I+1,I), 1, TAUQ1(I),
$ X21(I+1,I+1), LDX21, WORK )
CALL DLARF1F( 'L', Q-I, M-P-I, X11(I+1,I), 1,
$ TAUQ1(I), X21(I+1,I+1), LDX21, WORK )
END IF
CALL DLARF1F( 'L', M-Q-I+1, P-I, X12(I,I), 1, TAUQ2(I),
$ X12(I,I+1), LDX12, WORK )
$ X12(I,I+1), LDX12, WORK )
IF ( M-P-I .GT. 0 ) THEN
CALL DLARF1F( 'L', M-Q-I+1, M-P-I, X12(I,I), 1,
$ TAUQ2(I),
$ X22(I,I+1), LDX22, WORK )
$ TAUQ2(I), X22(I,I+1), LDX22, WORK )
END IF
*
END DO
Expand All @@ -660,13 +658,12 @@ SUBROUTINE DORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12,
$ TAUQ2(I) )
*
IF ( P .GT. I ) THEN
CALL DLARF1F( 'L', M-Q-I+1, P-I, X12(I,I), 1, TAUQ2(I),
$ X12(I,I+1), LDX12, WORK )
CALL DLARF1F( '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 DLARF1F( 'L', M-Q-I+1, M-P-Q, X12(I,I), 1,
$ TAUQ2(I),
$ X22(I,Q+1), LDX22, WORK )
$ TAUQ2(I), X22(I,Q+1), LDX22, WORK )
*
END DO
*
Expand All @@ -683,8 +680,9 @@ SUBROUTINE DORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12,
CALL DLARFGP( M-P-Q-I+1, X22(P+I,Q+I), X22(P+I+1,Q+I),
$ 1,
$ TAUQ2(P+I) )
CALL DLARF1F( '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 DLARF1F( '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
*
END DO
Expand Down
5 changes: 3 additions & 2 deletions SRC/dorbdb1.f
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -301,8 +301,9 @@ SUBROUTINE DORBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA,
S = X21(I,I+1)
CALL DLARF1F( 'R', P-I, Q-I, X21(I,I+1), LDX21, TAUQ1(I),
$ X11(I+1,I+1), LDX11, WORK(ILARF) )
CALL DLARF1F( 'R', M-P-I, Q-I, X21(I,I+1), LDX21, TAUQ1(I),
$ X21(I+1,I+1), LDX21, WORK(ILARF) )
CALL DLARF1F( 'R', M-P-I, Q-I, X21(I,I+1), LDX21,
$ TAUQ1(I), X21(I+1,I+1), LDX21,
$ WORK(ILARF) )
C = SQRT( DNRM2( P-I, X11(I+1,I+1), 1 )**2
$ + DNRM2( M-P-I, X21(I+1,I+1), 1 )**2 )
PHI(I) = ATAN2( S, C )
Expand Down
4 changes: 2 additions & 2 deletions SRC/dorbdb2.f
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -289,8 +289,8 @@ SUBROUTINE DORBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA,
C = X11(I,I)
CALL DLARF1F( 'R', P-I, Q-I+1, X11(I,I), LDX11, TAUQ1(I),
$ X11(I+1,I), LDX11, WORK(ILARF) )
CALL DLARF1F( 'R', M-P-I+1, Q-I+1, X11(I,I), LDX11, TAUQ1(I),
$ X21(I,I), LDX21, WORK(ILARF) )
CALL DLARF1F( 'R', M-P-I+1, Q-I+1, X11(I,I), LDX11,
$ TAUQ1(I), X21(I,I), LDX21, WORK(ILARF) )
S = SQRT( DNRM2( P-I, X11(I+1,I), 1 )**2
$ + DNRM2( M-P-I+1, X21(I,I), 1 )**2 )
THETA(I) = ATAN2( S, C )
Expand Down
13 changes: 6 additions & 7 deletions SRC/dorbdb4.f
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -308,10 +308,9 @@ SUBROUTINE DORBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA,
C = COS( THETA(I) )
S = SIN( THETA(I) )
CALL DLARF1F( 'L', P, Q, PHANTOM(1), 1, TAUP1(1), X11,
$ LDX11,
$ WORK(ILARF) )
CALL DLARF1F( 'L', M-P, Q, PHANTOM(P+1), 1, TAUP2(1), X21,
$ LDX21, WORK(ILARF) )
$ LDX11, WORK(ILARF) )
CALL DLARF1F( 'L', M-P, Q, PHANTOM(P+1), 1, TAUP2(1),
$ X21, LDX21, WORK(ILARF) )
ELSE
CALL DORBDB5( 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),
Expand All @@ -325,9 +324,9 @@ SUBROUTINE DORBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA,
C = COS( THETA(I) )
S = SIN( THETA(I) )
CALL DLARF1F( 'L', P-I+1, Q-I+1, X11(I,I-1), 1, TAUP1(I),
$ X11(I,I), LDX11, WORK(ILARF) )
CALL DLARF1F( 'L', M-P-I+1, Q-I+1, X21(I,I-1), 1, TAUP2(I),
$ X21(I,I), LDX21, WORK(ILARF) )
$ X11(I,I), LDX11, WORK(ILARF) )
CALL DLARF1F( 'L', M-P-I+1, Q-I+1, X21(I,I-1), 1,
$ TAUP2(I), X21(I,I), LDX21, WORK(ILARF) )
END IF
*
CALL DROT( Q-I+1, X11(I,I), LDX11, X21(I,I), LDX21, S, -C )
Expand Down
32 changes: 17 additions & 15 deletions SRC/zlarf1f.f
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -176,8 +176,6 @@ SUBROUTINE ZLARF1F( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )
COMPLEX*16 ONE, ZERO
PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ),
$ ZERO = ( 0.0D+0, 0.0D+0 ) )
INTEGER IONE
PARAMETER ( IONE = 1 )
* ..
* .. Local Scalars ..
LOGICAL APPLYLEFT
Expand Down Expand Up @@ -225,8 +223,8 @@ SUBROUTINE ZLARF1F( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )
! Scan for the last non-zero row in C(:,1:lastv).
LASTC = ILAZLR(M, LASTV, C, LDC)
END IF
ELSE
! TAU is 0, so H = I. Meaning HC = C = CH.
END IF
IF( LASTC.EQ.0 ) THEN
RETURN
END IF
IF( APPLYLEFT ) THEN
Expand All @@ -246,25 +244,29 @@ SUBROUTINE ZLARF1F( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )
! C = [ C_1 C_2 ]**T, v = [1 v_2]**T
! w = C_1**H + C_2**Hv_2
! w = C_2**Hv_2
CALL ZGEMV( 'Conj', LASTV-1, LASTC, ONE, C(1+1,1), LDC,
$ V(1+INCV), INCV, ZERO, WORK, 1)
! w += C_1**H
! This is essentially a zaxpyc
DO J = 1, LASTC
WORK(J) = WORK(J) + DCONJG(C(1,J))
CALL ZGEMV( 'Conjugate transpose', LASTV - 1,
$ LASTC, ONE, C( 1+1, 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 ) + DCONJG( C( 1, I ) )
END DO
*
* C(1:lastv,1:lastc) := C(...) - tau * v(1:lastv,1) * w(1:lastc,1)**H
*
! C(1, 1:lastc) := C(...) - tau * v(1,1) * w(1:lastc,1)**H
! = C(...) - tau * Conj(w(1:lastc,1))
! This is essentially a zaxpyc
DO J = 1, LASTC
C(1,J) = C(1,J) - TAU * DCONJG(WORK(J))
DO I = 1, LASTC
C( 1, I ) = C( 1, I ) - TAU * DCONJG( WORK( I ) )
END DO
! C(2:lastv,1:lastc) := C(...) - tau * v(2:lastv,1)*w(1:lastc,1)**H
CALL ZGERC(LASTV-1, LASTC, -TAU, V(1+INCV), INCV, WORK,
$ 1, C(1+1,1), LDC)
*
* C(2:lastv,1:lastc) += - tau * v(2:lastv,1) * w(1:lastc,1)**H
*
CALL ZGERC( LASTV - 1, LASTC, -TAU, V( 1 + INCV ),
$ INCV, WORK, 1, C( 1+1, 1 ), LDC )
END IF
ELSE
*
Expand Down