Skip to content

Commit dbc2fbd

Browse files
langoulangou
authored
Merge pull request #1020 from jprhyne/orm2r
Implementation of dorm2r and dlarf1f
2 parents a56dbda + 9a51a35 commit dbc2fbd

Some content is hidden

Large Commits have some content hidden by default. Use the searchbox below for content that may be hidden.

58 files changed

+1464
-514
lines changed

‎SRC/CMakeLists.txt‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -307,7 +307,7 @@ set(DLASRC
307307
dlaqgb.f dlaqge.f dlaqp2.f dlaqps.f dlaqp2rk.f dlaqp3rk.f dlaqsb.f dlaqsp.f dlaqsy.f
308308
dlaqr0.f dlaqr1.f dlaqr2.f dlaqr3.f dlaqr4.f dlaqr5.f
309309
dlaqtr.f dlar1v.f dlar2v.f iladlr.f iladlc.f
310-
dlarf.f dlarfb.f dlarfb_gett.f dlarfg.f dlarfgp.f dlarft.f dlarfx.f dlarfy.f
310+
dlarf.f dlarfb.f dlarfb_gett.f dlarfg.f dlarfgp.f dlarft.f dlarfx.f dlarfy.f dlarf1f.f dlarf1l.f
311311
dlargv.f dlarmm.f dlarrv.f dlartv.f
312312
dlarz.f dlarzb.f dlarzt.f dlaswp.f dlasy2.f
313313
dlasyf.f dlasyf_rook.f dlasyf_rk.f dlasyf_aa.f
@@ -418,7 +418,7 @@ set(ZLASRC
418418
zlaqhb.f zlaqhe.f zlaqhp.f zlaqp2.f zlaqps.f zlaqp2rk.f zlaqp3rk.f zlaqsb.f
419419
zlaqr0.f zlaqr1.f zlaqr2.f zlaqr3.f zlaqr4.f zlaqr5.f
420420
zlaqsp.f zlaqsy.f zlar1v.f zlar2v.f ilazlr.f ilazlc.f
421-
zlarcm.f zlarf.f zlarfb.f zlarfb_gett.f
421+
zlarcm.f zlarf.f zlarfb.f zlarfb_gett.f zlarf1f.f zlarf1l.f
422422
zlarfg.f zlarfgp.f zlarft.f
423423
zlarfx.f zlarfy.f zlargv.f zlarnv.f zlarrv.f zlartg.f90 zlartv.f
424424
zlarz.f zlarzb.f zlarzt.f zlascl.f zlaset.f zlasr.f

‎SRC/Makefile‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -339,7 +339,7 @@ DLASRC = \
339339
dlaqgb.o dlaqge.o dlaqp2.o dlaqps.o dlaqp2rk.o dlaqp3rk.o dlaqsb.o dlaqsp.o dlaqsy.o \
340340
dlaqr0.o dlaqr1.o dlaqr2.o dlaqr3.o dlaqr4.o dlaqr5.o \
341341
dlaqtr.o dlar1v.o dlar2v.o iladlr.o iladlc.o \
342-
dlarf.o dlarfb.o dlarfb_gett.o dlarfg.o dlarfgp.o dlarft.o dlarfx.o dlarfy.o \
342+
dlarf.o dlarfb.o dlarfb_gett.o dlarfg.o dlarfgp.o dlarft.o dlarfx.o dlarfy.o dlarf1f.o dlarf1l.o\
343343
dlargv.o dlarmm.o dlarrv.o dlartv.o \
344344
dlarz.o dlarzb.o dlarzt.o dlaswp.o dlasy2.o \
345345
dlasyf.o dlasyf_rook.o dlasyf_rk.o \
@@ -453,7 +453,7 @@ ZLASRC = \
453453
zlaqhb.o zlaqhe.o zlaqhp.o zlaqp2.o zlaqps.o zlaqp2rk.o zlaqp3rk.o zlaqsb.o \
454454
zlaqr0.o zlaqr1.o zlaqr2.o zlaqr3.o zlaqr4.o zlaqr5.o \
455455
zlaqsp.o zlaqsy.o zlar1v.o zlar2v.o ilazlr.o ilazlc.o \
456-
zlarcm.o zlarf.o zlarfb.o zlarfb_gett.o \
456+
zlarcm.o zlarf.o zlarfb.o zlarfb_gett.o zlarf1f.o zlarf1l.o \
457457
zlarfg.o zlarft.o zlarfgp.o \
458458
zlarfx.o zlarfy.o zlargv.o zlarnv.o zlarrv.o zlartg.o zlartv.o \
459459
zlarz.o zlarzb.o zlarzt.o zlascl.o zlaset.o zlasr.o \

‎SRC/dgebd2.f‎

Lines changed: 7 additions & 15 deletions
Original file line numberDiff line numberDiff line change
@@ -202,14 +202,14 @@ SUBROUTINE DGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO )
202202
* =====================================================================
203203
*
204204
* .. Parameters ..
205-
DOUBLE PRECISION ZERO, ONE
206-
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
205+
DOUBLE PRECISION ZERO
206+
PARAMETER ( ZERO = 0.0D+0 )
207207
* ..
208208
* .. Local Scalars ..
209209
INTEGER I
210210
* ..
211211
* .. External Subroutines ..
212-
EXTERNAL DLARF, DLARFG, XERBLA
212+
EXTERNAL DLARF1F, DLARFG, XERBLA
213213
* ..
214214
* .. Intrinsic Functions ..
215215
INTRINSIC MAX, MIN
@@ -242,15 +242,13 @@ SUBROUTINE DGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO )
242242
CALL DLARFG( M-I+1, A( I, I ), A( MIN( I+1, M ), I ), 1,
243243
$ TAUQ( I ) )
244244
D( I ) = A( I, I )
245-
A( I, I ) = ONE
246245
*
247246
* Apply H(i) to A(i:m,i+1:n) from the left
248247
*
249248
IF( I.LT.N )
250-
$ CALL DLARF( 'Left', M-I+1, N-I, A( I, I ), 1,
249+
$ CALL DLARF1F( 'Left', M-I+1, N-I, A( I, I ), 1,
251250
$ TAUQ( I ),
252251
$ A( I, I+1 ), LDA, WORK )
253-
A( I, I ) = D( I )
254252
*
255253
IF( I.LT.N ) THEN
256254
*
@@ -260,13 +258,11 @@ SUBROUTINE DGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO )
260258
CALL DLARFG( N-I, A( I, I+1 ), A( I, MIN( I+2, N ) ),
261259
$ LDA, TAUP( I ) )
262260
E( I ) = A( I, I+1 )
263-
A( I, I+1 ) = ONE
264261
*
265262
* Apply G(i) to A(i+1:m,i+1:n) from the right
266263
*
267-
CALL DLARF( 'Right', M-I, N-I, A( I, I+1 ), LDA,
264+
CALL DLARF1F( 'Right', M-I, N-I, A( I, I+1 ), LDA,
268265
$ TAUP( I ), A( I+1, I+1 ), LDA, WORK )
269-
A( I, I+1 ) = E( I )
270266
ELSE
271267
TAUP( I ) = ZERO
272268
END IF
@@ -283,14 +279,12 @@ SUBROUTINE DGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO )
283279
$ LDA,
284280
$ TAUP( I ) )
285281
D( I ) = A( I, I )
286-
A( I, I ) = ONE
287282
*
288283
* Apply G(i) to A(i+1:m,i:n) from the right
289284
*
290285
IF( I.LT.M )
291-
$ CALL DLARF( 'Right', M-I, N-I+1, A( I, I ), LDA,
286+
$ CALL DLARF1F( 'Right', M-I, N-I+1, A( I, I ), LDA,
292287
$ TAUP( I ), A( I+1, I ), LDA, WORK )
293-
A( I, I ) = D( I )
294288
*
295289
IF( I.LT.M ) THEN
296290
*
@@ -301,14 +295,12 @@ SUBROUTINE DGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO )
301295
$ 1,
302296
$ TAUQ( I ) )
303297
E( I ) = A( I+1, I )
304-
A( I+1, I ) = ONE
305298
*
306299
* Apply H(i) to A(i+1:m,i+1:n) from the left
307300
*
308-
CALL DLARF( 'Left', M-I, N-I, A( I+1, I ), 1,
301+
CALL DLARF1F( 'Left', M-I, N-I, A( I+1, I ), 1,
309302
$ TAUQ( I ),
310303
$ A( I+1, I+1 ), LDA, WORK )
311-
A( I+1, I ) = E( I )
312304
ELSE
313305
TAUQ( I ) = ZERO
314306
END IF

‎SRC/dgehd2.f‎

Lines changed: 3 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -166,10 +166,9 @@ SUBROUTINE DGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO )
166166
* ..
167167
* .. Local Scalars ..
168168
INTEGER I
169-
DOUBLE PRECISION AII
170169
* ..
171170
* .. External Subroutines ..
172-
EXTERNAL DLARF, DLARFG, XERBLA
171+
EXTERNAL DLARF1F, DLARFG, XERBLA
173172
* ..
174173
* .. Intrinsic Functions ..
175174
INTRINSIC MAX, MIN
@@ -199,20 +198,17 @@ SUBROUTINE DGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO )
199198
*
200199
CALL DLARFG( IHI-I, A( I+1, I ), A( MIN( I+2, N ), I ), 1,
201200
$ TAU( I ) )
202-
AII = A( I+1, I )
203-
A( I+1, I ) = ONE
204201
*
205202
* Apply H(i) to A(1:ihi,i+1:ihi) from the right
206203
*
207-
CALL DLARF( 'Right', IHI, IHI-I, A( I+1, I ), 1, TAU( I ),
204+
CALL DLARF1F( 'Right', IHI, IHI-I, A( I+1, I ), 1, TAU( I ),
208205
$ A( 1, I+1 ), LDA, WORK )
209206
*
210207
* Apply H(i) to A(i+1:ihi,i+1:n) from the left
211208
*
212-
CALL DLARF( 'Left', IHI-I, N-I, A( I+1, I ), 1, TAU( I ),
209+
CALL DLARF1F( 'Left', IHI-I, N-I, A( I+1, I ), 1, TAU( I ),
213210
$ A( I+1, I+1 ), LDA, WORK )
214211
*
215-
A( I+1, I ) = AII
216212
10 CONTINUE
217213
*
218214
RETURN

‎SRC/dgelq2.f‎

Lines changed: 2 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -146,10 +146,9 @@ SUBROUTINE DGELQ2( M, N, A, LDA, TAU, WORK, INFO )
146146
* ..
147147
* .. Local Scalars ..
148148
INTEGER I, K
149-
DOUBLE PRECISION AII
150149
* ..
151150
* .. External Subroutines ..
152-
EXTERNAL DLARF, DLARFG, XERBLA
151+
EXTERNAL DLARF1F, DLARFG, XERBLA
153152
* ..
154153
* .. Intrinsic Functions ..
155154
INTRINSIC MAX, MIN
@@ -183,12 +182,9 @@ SUBROUTINE DGELQ2( M, N, A, LDA, TAU, WORK, INFO )
183182
*
184183
* Apply H(i) to A(i+1:m,i:n) from the right
185184
*
186-
AII = A( I, I )
187-
A( I, I ) = ONE
188-
CALL DLARF( 'Right', M-I, N-I+1, A( I, I ), LDA,
185+
CALL DLARF1F( 'Right', M-I, N-I+1, A( I, I ), LDA,
189186
$ TAU( I ),
190187
$ A( I+1, I ), LDA, WORK )
191-
A( I, I ) = AII
192188
END IF
193189
10 CONTINUE
194190
RETURN

‎SRC/dgeql2.f‎

Lines changed: 2 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -140,10 +140,9 @@ SUBROUTINE DGEQL2( M, N, A, LDA, TAU, WORK, INFO )
140140
* ..
141141
* .. Local Scalars ..
142142
INTEGER I, K
143-
DOUBLE PRECISION AII
144143
* ..
145144
* .. External Subroutines ..
146-
EXTERNAL DLARF, DLARFG, XERBLA
145+
EXTERNAL DLARF1L, DLARFG, XERBLA
147146
* ..
148147
* .. Intrinsic Functions ..
149148
INTRINSIC MAX, MIN
@@ -177,12 +176,9 @@ SUBROUTINE DGEQL2( M, N, A, LDA, TAU, WORK, INFO )
177176
*
178177
* Apply H(i) to A(1:m-k+i,1:n-k+i-1) from the left
179178
*
180-
AII = A( M-K+I, N-K+I )
181-
A( M-K+I, N-K+I ) = ONE
182-
CALL DLARF( 'Left', M-K+I, N-K+I-1, A( 1, N-K+I ), 1,
179+
CALL DLARF1L( 'Left', M-K+I, N-K+I-1, A( 1, N-K+I ), 1,
183180
$ TAU( I ),
184181
$ A, LDA, WORK )
185-
A( M-K+I, N-K+I ) = AII
186182
10 CONTINUE
187183
RETURN
188184
*

‎SRC/dgeqp3rk.f‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -670,7 +670,7 @@ SUBROUTINE DGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, A, LDA,
670670
* 1) DGEQP3RK and DLAQP2RK: 2*N to store full and partial
671671
* column 2-norms.
672672
* 2) DLAQP2RK: N+NRHS-1 to use in WORK array that is used
673-
* in DLARF subroutine inside DLAQP2RK to apply an
673+
* in DLARF1F subroutine inside DLAQP2RK to apply an
674674
* elementary reflector from the left.
675675
* TOTAL_WORK_SIZE = 3*N + NRHS - 1
676676
*
@@ -686,7 +686,7 @@ SUBROUTINE DGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, A, LDA,
686686
* 1) DGEQP3RK, DLAQP2RK, DLAQP3RK: 2*N to store full and
687687
* partial column 2-norms.
688688
* 2) DLAQP2RK: N+NRHS-1 to use in WORK array that is used
689-
* in DLARF subroutine to apply an elementary reflector
689+
* in DLARF1F subroutine to apply an elementary reflector
690690
* from the left.
691691
* 3) DLAQP3RK: NB*(N+NRHS) to use in the work array F that
692692
* is used to apply a block reflector from

‎SRC/dgeqr2.f‎

Lines changed: 2 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -147,10 +147,9 @@ SUBROUTINE DGEQR2( M, N, A, LDA, TAU, WORK, INFO )
147147
* ..
148148
* .. Local Scalars ..
149149
INTEGER I, K
150-
DOUBLE PRECISION AII
151150
* ..
152151
* .. External Subroutines ..
153-
EXTERNAL DLARF, DLARFG, XERBLA
152+
EXTERNAL DLARF1F, DLARFG, XERBLA
154153
* ..
155154
* .. Intrinsic Functions ..
156155
INTRINSIC MAX, MIN
@@ -184,11 +183,8 @@ SUBROUTINE DGEQR2( M, N, A, LDA, TAU, WORK, INFO )
184183
*
185184
* Apply H(i) to A(i:m,i+1:n) from the left
186185
*
187-
AII = A( I, I )
188-
A( I, I ) = ONE
189-
CALL DLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ),
186+
CALL DLARF1F( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ),
190187
$ A( I, I+1 ), LDA, WORK )
191-
A( I, I ) = AII
192188
END IF
193189
10 CONTINUE
194190
RETURN

‎SRC/dgeqr2p.f‎

Lines changed: 2 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -151,10 +151,9 @@ SUBROUTINE DGEQR2P( M, N, A, LDA, TAU, WORK, INFO )
151151
* ..
152152
* .. Local Scalars ..
153153
INTEGER I, K
154-
DOUBLE PRECISION AII
155154
* ..
156155
* .. External Subroutines ..
157-
EXTERNAL DLARF, DLARFGP, XERBLA
156+
EXTERNAL DLARF1F, DLARFGP, XERBLA
158157
* ..
159158
* .. Intrinsic Functions ..
160159
INTRINSIC MAX, MIN
@@ -188,11 +187,8 @@ SUBROUTINE DGEQR2P( M, N, A, LDA, TAU, WORK, INFO )
188187
*
189188
* Apply H(i) to A(i:m,i+1:n) from the left
190189
*
191-
AII = A( I, I )
192-
A( I, I ) = ONE
193-
CALL DLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ),
190+
CALL DLARF1F( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ),
194191
$ A( I, I+1 ), LDA, WORK )
195-
A( I, I ) = AII
196192
END IF
197193
10 CONTINUE
198194
RETURN

‎SRC/dgerq2.f‎

Lines changed: 2 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -140,10 +140,9 @@ SUBROUTINE DGERQ2( M, N, A, LDA, TAU, WORK, INFO )
140140
* ..
141141
* .. Local Scalars ..
142142
INTEGER I, K
143-
DOUBLE PRECISION AII
144143
* ..
145144
* .. External Subroutines ..
146-
EXTERNAL DLARF, DLARFG, XERBLA
145+
EXTERNAL DLARF1L, DLARFG, XERBLA
147146
* ..
148147
* .. Intrinsic Functions ..
149148
INTRINSIC MAX, MIN
@@ -177,11 +176,8 @@ SUBROUTINE DGERQ2( M, N, A, LDA, TAU, WORK, INFO )
177176
*
178177
* Apply H(i) to A(1:m-k+i-1,1:n-k+i) from the right
179178
*
180-
AII = A( M-K+I, N-K+I )
181-
A( M-K+I, N-K+I ) = ONE
182-
CALL DLARF( 'Right', M-K+I-1, N-K+I, A( M-K+I, 1 ), LDA,
179+
CALL DLARF1L( 'Right', M-K+I-1, N-K+I, A( M-K+I, 1 ), LDA,
183180
$ TAU( I ), A, LDA, WORK )
184-
A( M-K+I, N-K+I ) = AII
185181
10 CONTINUE
186182
RETURN
187183
*

0 commit comments

Comments
 (0)