Skip to content

Commit 8dd7e13

Browse files
EduardFedorenkovEduardFedorenkov
committed
update single precision routines to use slarf1f and slarf1l, #1011 
1 parent 5e7dad3 commit 8dd7e13

24 files changed

+208
-288
lines changed

‎SRC/sgebd2.f

Lines changed: 11 additions & 19 deletions
Original file line numberDiff line numberDiff line change
@@ -209,7 +209,7 @@ SUBROUTINE SGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO )
209209
INTEGER I
210210
* ..
211211
* .. External Subroutines ..
212-
EXTERNAL SLARF, SLARFG, XERBLA
212+
EXTERNAL SLARF1F, SLARFG, XERBLA
213213
* ..
214214
* .. Intrinsic Functions ..
215215
INTRINSIC MAX, MIN
@@ -242,15 +242,13 @@ SUBROUTINE SGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO )
242242
CALL SLARFG( 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 SLARF( 'Left', M-I+1, N-I, A( I, I ), 1,
251-
$ TAUQ( I ),
252-
$ A( I, I+1 ), LDA, WORK )
253-
A( I, I ) = D( I )
249+
$ CALL SLARF1F( 'Left', M-I+1, N-I, A( I, I ), 1,
250+
$ TAUQ( I ),
251+
$ A( I, I+1 ), LDA, WORK )
254252
*
255253
IF( I.LT.N ) THEN
256254
*
@@ -260,13 +258,11 @@ SUBROUTINE SGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO )
260258
CALL SLARFG( 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 SLARF( 'Right', M-I, N-I, A( I, I+1 ), LDA,
268-
$ TAUP( I ), A( I+1, I+1 ), LDA, WORK )
269-
A( I, I+1 ) = E( I )
264+
CALL SLARF1F( 'Right', M-I, N-I, A( I, I+1 ), LDA,
265+
$ TAUP( I ), A( I+1, I+1 ), LDA, WORK )
270266
ELSE
271267
TAUP( I ) = ZERO
272268
END IF
@@ -283,14 +279,12 @@ SUBROUTINE SGEBD2( 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 SLARF( 'Right', M-I, N-I+1, A( I, I ), LDA,
292-
$ TAUP( I ), A( I+1, I ), LDA, WORK )
293-
A( I, I ) = D( I )
286+
$ CALL SLARF1F( 'Right', M-I, N-I+1, A( I, I ), LDA,
287+
$ TAUP( I ), A( I+1, I ), LDA, WORK )
294288
*
295289
IF( I.LT.M ) THEN
296290
*
@@ -301,14 +295,12 @@ SUBROUTINE SGEBD2( 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 SLARF( 'Left', M-I, N-I, A( I+1, I ), 1,
309-
$ TAUQ( I ),
310-
$ A( I+1, I+1 ), LDA, WORK )
311-
A( I+1, I ) = E( I )
301+
CALL SLARF1F( 'Left', M-I, N-I, A( I+1, I ), 1,
302+
$ TAUQ( I ),
303+
$ A( I+1, I+1 ), LDA, WORK )
312304
ELSE
313305
TAUQ( I ) = ZERO
314306
END IF

‎SRC/sgehd2.f

Lines changed: 5 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -166,10 +166,9 @@ SUBROUTINE SGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO )
166166
* ..
167167
* .. Local Scalars ..
168168
INTEGER I
169-
REAL AII
170169
* ..
171170
* .. External Subroutines ..
172-
EXTERNAL SLARF, SLARFG, XERBLA
171+
EXTERNAL SLARF1F, SLARFG, XERBLA
173172
* ..
174173
* .. Intrinsic Functions ..
175174
INTRINSIC MAX, MIN
@@ -199,20 +198,17 @@ SUBROUTINE SGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO )
199198
*
200199
CALL SLARFG( 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 SLARF( 'Right', IHI, IHI-I, A( I+1, I ), 1, TAU( I ),
208-
$ A( 1, I+1 ), LDA, WORK )
204+
CALL SLARF1F( 'Right', IHI, IHI-I, A( I+1, I ), 1, TAU( I ),
205+
$ 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 SLARF( 'Left', IHI-I, N-I, A( I+1, I ), 1, TAU( I ),
213-
$ A( I+1, I+1 ), LDA, WORK )
209+
CALL SLARF1F( 'Left', IHI-I, N-I, A( I+1, I ), 1, TAU( I ),
210+
$ A( I+1, I+1 ), LDA, WORK )
214211
*
215-
A( I+1, I ) = AII
216212
10 CONTINUE
217213
*
218214
RETURN

‎SRC/sgelq2.f

Lines changed: 4 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -146,10 +146,9 @@ SUBROUTINE SGELQ2( M, N, A, LDA, TAU, WORK, INFO )
146146
* ..
147147
* .. Local Scalars ..
148148
INTEGER I, K
149-
REAL AII
150149
* ..
151150
* .. External Subroutines ..
152-
EXTERNAL SLARF, SLARFG, XERBLA
151+
EXTERNAL SLARF1F, SLARFG, XERBLA
153152
* ..
154153
* .. Intrinsic Functions ..
155154
INTRINSIC MAX, MIN
@@ -183,12 +182,9 @@ SUBROUTINE SGELQ2( 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 SLARF( 'Right', M-I, N-I+1, A( I, I ), LDA,
189-
$ TAU( I ),
190-
$ A( I+1, I ), LDA, WORK )
191-
A( I, I ) = AII
185+
CALL SLARF1F( 'Right', M-I, N-I+1, A( I, I ), LDA,
186+
$ TAU( I ),
187+
$ A( I+1, I ), LDA, WORK )
192188
END IF
193189
10 CONTINUE
194190
RETURN

‎SRC/sgeql2.f

Lines changed: 4 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -140,10 +140,9 @@ SUBROUTINE SGEQL2( M, N, A, LDA, TAU, WORK, INFO )
140140
* ..
141141
* .. Local Scalars ..
142142
INTEGER I, K
143-
REAL AII
144143
* ..
145144
* .. External Subroutines ..
146-
EXTERNAL SLARF, SLARFG, XERBLA
145+
EXTERNAL SLARF1L, SLARFG, XERBLA
147146
* ..
148147
* .. Intrinsic Functions ..
149148
INTRINSIC MAX, MIN
@@ -177,12 +176,9 @@ SUBROUTINE SGEQL2( 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 SLARF( 'Left', M-K+I, N-K+I-1, A( 1, N-K+I ), 1,
183-
$ TAU( I ),
184-
$ A, LDA, WORK )
185-
A( M-K+I, N-K+I ) = AII
179+
CALL SLARF1L( 'Left', M-K+I, N-K+I-1, A( 1, N-K+I ), 1,
180+
$ TAU( I ),
181+
$ A, LDA, WORK )
186182
10 CONTINUE
187183
RETURN
188184
*

‎SRC/sgeqp3rk.f

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -671,7 +671,7 @@ SUBROUTINE SGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, A, LDA,
671671
* 1) SGEQP3RK and SLAQP2RK: 2*N to store full and partial
672672
* column 2-norms.
673673
* 2) SLAQP2RK: N+NRHS-1 to use in WORK array that is used
674-
* in SLARF subroutine inside SLAQP2RK to apply an
674+
* in SLARF1F subroutine inside SLAQP2RK to apply an
675675
* elementary reflector from the left.
676676
* TOTAL_WORK_SIZE = 3*N + NRHS - 1
677677
*
@@ -687,7 +687,7 @@ SUBROUTINE SGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, A, LDA,
687687
* 1) SGEQP3RK, SLAQP2RK, SLAQP3RK: 2*N to store full and
688688
* partial column 2-norms.
689689
* 2) SLAQP2RK: N+NRHS-1 to use in WORK array that is used
690-
* in SLARF subroutine to apply an elementary reflector
690+
* in SLARF1F subroutine to apply an elementary reflector
691691
* from the left.
692692
* 3) SLAQP3RK: NB*(N+NRHS) to use in the work array F that
693693
* is used to apply a block reflector from

‎SRC/sgeqr2.f

Lines changed: 3 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -147,10 +147,9 @@ SUBROUTINE SGEQR2( M, N, A, LDA, TAU, WORK, INFO )
147147
* ..
148148
* .. Local Scalars ..
149149
INTEGER I, K
150-
REAL AII
151150
* ..
152151
* .. External Subroutines ..
153-
EXTERNAL SLARF, SLARFG, XERBLA
152+
EXTERNAL SLARF1F, SLARFG, XERBLA
154153
* ..
155154
* .. Intrinsic Functions ..
156155
INTRINSIC MAX, MIN
@@ -184,11 +183,8 @@ SUBROUTINE SGEQR2( 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 SLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ),
190-
$ A( I, I+1 ), LDA, WORK )
191-
A( I, I ) = AII
186+
CALL SLARF1F( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ),
187+
$ A( I, I+1 ), LDA, WORK )
192188
END IF
193189
10 CONTINUE
194190
RETURN

‎SRC/sgeqr2p.f

Lines changed: 3 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -151,10 +151,9 @@ SUBROUTINE SGEQR2P( M, N, A, LDA, TAU, WORK, INFO )
151151
* ..
152152
* .. Local Scalars ..
153153
INTEGER I, K
154-
REAL AII
155154
* ..
156155
* .. External Subroutines ..
157-
EXTERNAL SLARF, SLARFGP, XERBLA
156+
EXTERNAL SLARF1F, SLARFGP, XERBLA
158157
* ..
159158
* .. Intrinsic Functions ..
160159
INTRINSIC MAX, MIN
@@ -188,11 +187,8 @@ SUBROUTINE SGEQR2P( 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 SLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ),
194-
$ A( I, I+1 ), LDA, WORK )
195-
A( I, I ) = AII
190+
CALL SLARF1F( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ),
191+
$ A( I, I+1 ), LDA, WORK )
196192
END IF
197193
10 CONTINUE
198194
RETURN

‎SRC/sgerq2.f

Lines changed: 3 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -140,10 +140,9 @@ SUBROUTINE SGERQ2( M, N, A, LDA, TAU, WORK, INFO )
140140
* ..
141141
* .. Local Scalars ..
142142
INTEGER I, K
143-
REAL AII
144143
* ..
145144
* .. External Subroutines ..
146-
EXTERNAL SLARF, SLARFG, XERBLA
145+
EXTERNAL SLARF1L, SLARFG, XERBLA
147146
* ..
148147
* .. Intrinsic Functions ..
149148
INTRINSIC MAX, MIN
@@ -177,11 +176,8 @@ SUBROUTINE SGERQ2( 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 SLARF( 'Right', M-K+I-1, N-K+I, A( M-K+I, 1 ), LDA,
183-
$ TAU( I ), A, LDA, WORK )
184-
A( M-K+I, N-K+I ) = AII
179+
CALL SLARF1L( 'Right', M-K+I-1, N-K+I, A( M-K+I, 1 ), LDA,
180+
$ TAU( I ), A, LDA, WORK )
185181
10 CONTINUE
186182
RETURN
187183
*

‎SRC/slaqp2.f

Lines changed: 4 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -168,10 +168,10 @@ SUBROUTINE SLAQP2( M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2,
168168
* ..
169169
* .. Local Scalars ..
170170
INTEGER I, ITEMP, J, MN, OFFPI, PVT
171-
REAL AII, TEMP, TEMP2, TOL3Z
171+
REAL TEMP, TEMP2, TOL3Z
172172
* ..
173173
* .. External Subroutines ..
174-
EXTERNAL SLARF, SLARFG, SSWAP
174+
EXTERNAL SLARF1F, SLARFG, SSWAP
175175
* ..
176176
* .. Intrinsic Functions ..
177177
INTRINSIC ABS, MAX, MIN, SQRT
@@ -219,11 +219,8 @@ SUBROUTINE SLAQP2( M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2,
219219
*
220220
* Apply H(i)**T to A(offset+i:m,i+1:n) from the left.
221221
*
222-
AII = A( OFFPI, I )
223-
A( OFFPI, I ) = ONE
224-
CALL SLARF( 'Left', M-OFFPI+1, N-I, A( OFFPI, I ), 1,
225-
$ TAU( I ), A( OFFPI, I+1 ), LDA, WORK( 1 ) )
226-
A( OFFPI, I ) = AII
222+
CALL SLARF1F( 'Left', M-OFFPI+1, N-I, A( OFFPI, I ), 1,
223+
$ TAU( I ), A( OFFPI, I+1 ), LDA, WORK( 1 ) )
227224
END IF
228225
*
229226
* Update partial column norms.

‎SRC/slaqp2rk.f

Lines changed: 5 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -253,7 +253,7 @@
253253
*> \param[out] WORK
254254
*> \verbatim
255255
*> WORK is REAL array, dimension (N-1)
256-
*> Used in SLARF subroutine to apply an elementary
256+
*> Used in SLARF1F subroutine to apply an elementary
257257
*> reflector from the left.
258258
*> \endverbatim
259259
*>
@@ -367,10 +367,10 @@ SUBROUTINE SLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL,
367367
* .. Local Scalars ..
368368
INTEGER I, ITEMP, J, JMAXC2NRM, KK, KP, MINMNFACT,
369369
$ MINMNUPDT
370-
REAL AIKK, HUGEVAL, TEMP, TEMP2, TOL3Z
370+
REAL HUGEVAL, TEMP, TEMP2, TOL3Z
371371
* ..
372372
* .. External Subroutines ..
373-
EXTERNAL SLARF, SLARFG, SSWAP
373+
EXTERNAL SLARF1F, SLARFG, SSWAP
374374
* ..
375375
* .. Intrinsic Functions ..
376376
INTRINSIC ABS, MAX, MIN, SQRT
@@ -621,11 +621,8 @@ SUBROUTINE SLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL,
621621
* condition is satisfied, not only KK < N+NRHS )
622622
*
623623
IF( KK.LT.MINMNUPDT ) THEN
624-
AIKK = A( I, KK )
625-
A( I, KK ) = ONE
626-
CALL SLARF( 'Left', M-I+1, N+NRHS-KK, A( I, KK ), 1,
627-
$ TAU( KK ), A( I, KK+1 ), LDA, WORK( 1 ) )
628-
A( I, KK ) = AIKK
624+
CALL SLARF1F( 'Left', M-I+1, N+NRHS-KK, A( I, KK ), 1,
625+
$ TAU( KK ), A( I, KK+1 ), LDA, WORK( 1 ) )
629626
END IF
630627
*
631628
IF( KK.LT.MINMNFACT ) THEN

0 commit comments

Comments
 (0)