Skip to content

Commit 797ed89

Browse files
EduardFedorenkovEduardFedorenkov
committed
remove dlarf1f prototype and add slarf1f, slarf1l, #1011 
1 parent a4698c3 commit 797ed89

File tree

7 files changed

+311
-60
lines changed

7 files changed

+311
-60
lines changed

‎SRC/CMakeLists.txt

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -106,7 +106,7 @@ set(SLASRC
106106
slaqgb.f slaqge.f slaqp2.f slaqps.f slaqp2rk.f slaqp3rk.f slaqsb.f slaqsp.f slaqsy.f
107107
slaqr0.f slaqr1.f slaqr2.f slaqr3.f slaqr4.f slaqr5.f
108108
slaqtr.f slar1v.f slar2v.f ilaslr.f ilaslc.f
109-
slarf.f slarfb.f slarfb_gett.f slarfg.f slarfgp.f slarft.f slarfx.f slarfy.f
109+
slarf.f slarf1f.f slarf1l.f slarfb.f slarfb_gett.f slarfg.f slarfgp.f slarft.f slarfx.f slarfy.f
110110
slargv.f slarmm.f slarrv.f slartv.f
111111
slarz.f slarzb.f slarzt.f slasy2.f
112112
slasyf.f slasyf_rook.f slasyf_rk.f slasyf_aa.f
@@ -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 dlarf1f.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
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

‎SRC/Makefile

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -137,7 +137,7 @@ SLASRC = \
137137
slaqgb.o slaqge.o slaqp2.o slaqps.o slaqp2rk.o slaqp3rk.o slaqsb.o slaqsp.o slaqsy.o \
138138
slaqr0.o slaqr1.o slaqr2.o slaqr3.o slaqr4.o slaqr5.o \
139139
slaqtr.o slar1v.o slar2v.o ilaslr.o ilaslc.o \
140-
slarf.o slarfb.o slarfb_gett.o slarfg.o slarfgp.o slarft.o slarfx.o slarfy.o \
140+
slarf.o slarf1f.o slarf1l.o slarfb.o slarfb_gett.o slarfg.o slarfgp.o slarft.o slarfx.o slarfy.o \
141141
slargv.o slarmm.o slarrv.o slartv.o \
142142
slarz.o slarzb.o slarzt.o slaswp.o slasy2.o slasyf.o slasyf_rook.o \
143143
slasyf_rk.o \
@@ -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 dlarf1f.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 \
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 \

‎SRC/dorm2r.f

Lines changed: 8 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -178,13 +178,14 @@ SUBROUTINE DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
178178
* .. Local Scalars ..
179179
LOGICAL LEFT, NOTRAN
180180
INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ
181+
DOUBLE PRECISION AII
181182
* ..
182183
* .. External Functions ..
183184
LOGICAL LSAME
184185
EXTERNAL LSAME
185186
* ..
186187
* .. External Subroutines ..
187-
EXTERNAL DLARF1F, XERBLA
188+
EXTERNAL DLARF, XERBLA
188189
* ..
189190
* .. Intrinsic Functions ..
190191
INTRINSIC MAX
@@ -265,9 +266,12 @@ SUBROUTINE DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
265266
*
266267
* Apply H(i)
267268
*
268-
CALL DLARF1F( SIDE, MI, NI, A( I, I ), 1, TAU( I ), C( IC,
269-
$ JC ),
270-
$ LDC, WORK )
269+
AII = A( I, I )
270+
A( I, I ) = ONE
271+
CALL DLARF( SIDE, MI, NI, A( I, I ), 1, TAU( I ), C( IC,
272+
$ JC ),
273+
$ LDC, WORK )
274+
A( I, I ) = AII
271275
10 CONTINUE
272276
RETURN
273277
*

‎SRC/dlarf1f.f renamed to ‎SRC/slarf1f.f

Lines changed: 38 additions & 38 deletions
Original file line numberDiff line numberDiff line change
@@ -1,4 +1,4 @@
1-
*> \brief \b DLARF1F applies an elementary reflector to a general rectangular
1+
*> \brief \b SLARF1F applies an elementary reflector to a general rectangular
22
* matrix assuming v(1) = 1.
33
*
44
* =========== DOCUMENTATION ===========
@@ -7,27 +7,27 @@
77
* http://www.netlib.org/lapack/explore-html/
88
*
99
*> \htmlonly
10-
*> Download DLARF + dependencies
11-
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlarf.f">
10+
*> Download SLARF1F + dependencies
11+
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/slarf.f">
1212
*> [TGZ]</a>
13-
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlarf.f">
13+
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/slarf.f">
1414
*> [ZIP]</a>
15-
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlarf.f">
15+
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/slarf.f">
1616
*> [TXT]</a>
1717
*> \endhtmlonly
1818
*
1919
* Definition:
2020
* ===========
2121
*
22-
* SUBROUTINE DLARF1F( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )
22+
* SUBROUTINE SLARF1F( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )
2323
*
2424
* .. Scalar Arguments ..
2525
* CHARACTER SIDE
2626
* INTEGER INCV, LDC, M, N
27-
* DOUBLE PRECISION TAU
27+
* REAL TAU
2828
* ..
2929
* .. Array Arguments ..
30-
* DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * )
30+
* REAL C( LDC, * ), V( * ), WORK( * )
3131
* ..
3232
*
3333
*
@@ -36,7 +36,7 @@
3636
*>
3737
*> \verbatim
3838
*>
39-
*> DLARF1F applies a real elementary reflector H to a real m by n matrix
39+
*> SLARF1F applies a real elementary reflector H to a real m by n matrix
4040
*> C, from either the left or the right. H is represented in the form
4141
*>
4242
*> H = I - tau * v * v**T
@@ -70,7 +70,7 @@
7070
*>
7171
*> \param[in] V
7272
*> \verbatim
73-
*> V is DOUBLE PRECISION array, dimension
73+
*> V is REAL array, dimension
7474
*> (1 + (M-1)*abs(INCV)) if SIDE = 'L'
7575
*> or (1 + (N-1)*abs(INCV)) if SIDE = 'R'
7676
*> The vector v in the representation of H. V is not used if
@@ -85,13 +85,13 @@
8585
*>
8686
*> \param[in] TAU
8787
*> \verbatim
88-
*> TAU is DOUBLE PRECISION
88+
*> TAU is REAL
8989
*> The value tau in the representation of H.
9090
*> \endverbatim
9191
*>
9292
*> \param[in,out] C
9393
*> \verbatim
94-
*> C is DOUBLE PRECISION array, dimension (LDC,N)
94+
*> C is REAL array, dimension (LDC,N)
9595
*> On entry, the m by n matrix C.
9696
*> On exit, C is overwritten by the matrix H * C if SIDE = 'L',
9797
*> or C * H if SIDE = 'R'.
@@ -105,7 +105,7 @@
105105
*>
106106
*> \param[out] WORK
107107
*> \verbatim
108-
*> WORK is DOUBLE PRECISION array, dimension
108+
*> WORK is REAL array, dimension
109109
*> (N) if SIDE = 'L'
110110
*> or (M) if SIDE = 'R'
111111
*> \endverbatim
@@ -121,7 +121,7 @@
121121
*> \ingroup larf1f
122122
*
123123
* =====================================================================
124-
SUBROUTINE DLARF1F( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )
124+
SUBROUTINE SLARF1F( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )
125125
*
126126
* -- LAPACK auxiliary routine --
127127
* -- LAPACK is a software package provided by Univ. of Tennessee, --
@@ -130,24 +130,24 @@ SUBROUTINE DLARF1F( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )
130130
* .. Scalar Arguments ..
131131
CHARACTER SIDE
132132
INTEGER INCV, LDC, M, N
133-
DOUBLE PRECISION TAU
133+
REAL TAU
134134
* ..
135135
* .. Array Arguments ..
136-
DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * )
136+
REAL C( LDC, * ), V( * ), WORK( * )
137137
* ..
138138
*
139139
* =====================================================================
140140
*
141141
* .. Parameters ..
142-
DOUBLE PRECISION ONE, ZERO
143-
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
142+
REAL ONE, ZERO
143+
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
144144
* ..
145145
* .. Local Scalars ..
146146
LOGICAL APPLYLEFT
147147
INTEGER I, LASTV, LASTC
148148
* ..
149149
* .. External Subroutines ..
150-
EXTERNAL DGEMV, DGER, DAXPY
150+
EXTERNAL SGEMV, SGER, SAXPY, SSCAL
151151
* ..
152152
* .. External Functions ..
153153
LOGICAL LSAME
@@ -196,25 +196,25 @@ SUBROUTINE DLARF1F( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )
196196
*
197197
* C(1,1:lastc) := ( 1 - tau ) * C(1,1:lastc)
198198
*
199-
CALL DSCAL( LASTC, ONE - TAU, C, LDC )
199+
CALL SSCAL( LASTC, ONE - TAU, C, LDC )
200200
ELSE
201201
*
202202
* w(1:lastc,1) := C(2:lastv,1:lastc)**T * v(2:lastv,1)
203203
*
204-
CALL DGEMV( 'Transpose', LASTV - 1, LASTC, ONE, C( 2, 1 ),
204+
CALL SGEMV( 'Transpose', LASTV - 1, LASTC, ONE, C( 2, 1 ),
205205
$ LDC, V( 1 + INCV ), INCV, ZERO, WORK, 1 )
206206
*
207-
* w(1:lastc,1) += C(1,1:lastc)**T * v(1,1)
207+
* w(1:lastc,1) += v(1,1) * C(1,1:lastc)**T
208208
*
209-
CALL DAXPY( LASTC, ONE, C, LDC, WORK, 1 )
209+
CALL SAXPY( LASTC, ONE, C, LDC, WORK, 1 )
210210
*
211-
* C(1, 1:lastc) := C(...) - tau * w(1:lastc,1)**T
211+
* C(1, 1:lastc) += - tau * v(1,1) * w(1:lastc,1)**T
212212
*
213-
CALL DAXPY( LASTC, -TAU, WORK, 1, C, LDC )
213+
CALL SAXPY( LASTC, -TAU, WORK, 1, C, LDC )
214214
*
215-
* C(2:lastv,1:lastc) := C(...) - tau * v(2:lastv,1)*w(1:lastc,1)**T
215+
* C(2:lastv,1:lastc) += - tau * v(2:lastv,1) * w(1:lastc,1)**T
216216
*
217-
CALL DGER( LASTV - 1, LASTC, -TAU, V( 1 + INCV ), INCV, WORK,
217+
CALL SGER( LASTV - 1, LASTC, -TAU, V( 1 + INCV ), INCV, WORK,
218218
$ 1, C( 2, 1 ), LDC )
219219
END IF
220220
ELSE
@@ -225,30 +225,30 @@ SUBROUTINE DLARF1F( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )
225225
*
226226
* C(1:lastc,1) := ( 1 - tau ) * C(1:lastc,1)
227227
*
228-
CALL DSCAL( LASTC, ONE - TAU, C, 1 )
228+
CALL SSCAL( LASTC, ONE - TAU, C, 1 )
229229
ELSE
230230
*
231231
* w(1:lastc,1) := C(1:lastc,2:lastv) * v(2:lastv,1)
232232
*
233-
CALL DGEMV( 'No transpose', LASTC, LASTV - 1, ONE,
234-
$ C( 1, 2 ), LDC, V( 1 + INCV ), INCV, ZERO, WORK, 1 )
233+
CALL SGEMV( 'No transpose', LASTC, LASTV - 1, ONE,
234+
$ C( 1, 2 ), LDC, V( 1 + INCV ), INCV, ZERO, WORK, 1 )
235235
*
236-
* w(1:lastc,1) += C(1:lastc,1) * v(1,1)
236+
* w(1:lastc,1) += v(1,1) * C(1:lastc,1)
237237
*
238-
CALL DAXPY( LASTC, ONE, C, 1, WORK, 1 )
238+
CALL SAXPY( LASTC, ONE, C, 1, WORK, 1 )
239239
*
240-
* C(1:lastc,1) := C(1:lastc,1) - tau * w(1:lastc,1)
240+
* C(1:lastc,1) += - tau * v(1,1) * w(1:lastc,1)
241241
*
242-
CALL DAXPY( LASTC, -TAU, WORK, 1, C, 1 )
242+
CALL SAXPY( LASTC, -TAU, WORK, 1, C, 1 )
243243
*
244-
* C(1:lastc,2:lastv) := C(1:lastc,2:lastv) - tau * w(1:lastc,1) * v(2:lastv)**T
244+
* C(1:lastc,2:lastv) += - tau * w(1:lastc,1) * v(2:lastv)**T
245245
*
246-
CALL DGER( LASTC, LASTV - 1, -TAU, WORK, 1, V( 1 + INCV ),
247-
$ INCV, C( 1, 2 ), LDC )
246+
CALL SGER( LASTC, LASTV - 1, -TAU, WORK, 1, V( 1 + INCV ),
247+
$ INCV, C( 1, 2 ), LDC )
248248
END IF
249249
END IF
250250
RETURN
251251
*
252-
* End of DLARF1F
252+
* End of SLARF1F
253253
*
254254
END

0 commit comments

Comments
 (0)