Skip to content

Commit fb5dc39

Browse files
jprhynejprhyne
committed
current state of testing implementation
1 parent 2ec963d commit fb5dc39

File tree

5 files changed

+2076
-48
lines changed

5 files changed

+2076
-48
lines changed

‎SRC/Makefile

Lines changed: 1 addition & 1 deletion
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 dlarf1.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/dlarf1.f

Lines changed: 17 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -120,7 +120,7 @@
120120
*> \ingroup larf
121121
*
122122
* =====================================================================
123-
SUBROUTINE DLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )
123+
SUBROUTINE DLARF1( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )
124124
*
125125
* -- LAPACK auxiliary routine --
126126
* -- LAPACK is a software package provided by Univ. of Tennessee, --
@@ -145,7 +145,7 @@ SUBROUTINE DLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )
145145
* ..
146146
* .. Local Scalars ..
147147
LOGICAL APPLYLEFT
148-
INTEGER I, LASTV, LASTC
148+
INTEGER I, LASTV, LASTC, J
149149
* ..
150150
* .. External Subroutines ..
151151
EXTERNAL DGEMV, DGER
@@ -192,16 +192,28 @@ SUBROUTINE DLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )
192192
*
193193
* Form H * C
194194
*
195-
IF( LASTV.GT.0 ) THEN
195+
IF( LASTV.GT.0 .AND. LASTC.GT.0) THEN
196196
*
197197
* w(1:lastc,1) := C(2:lastv,1:lastc)**T * v(2:lastv,1)
198198
*
199-
CALL DGEMV( 'Transpose', LASTV, LASTC, ONE, C(2,1), LDC,
200-
$ V(INCV), INCV, ZERO, WORK, 1 )
199+
! CALL DGEMV( 'Transpose', LASTV-1, LASTC, ONE, C(1+1,1), LDC,
200+
! $ V(1+INCV), INCV, ZERO, WORK, 1 )
201+
! DO I = 1, LASTC
202+
! WORK(I) = ZERO
203+
! DO J = 2, LASTV
204+
! WORK(I) = WORK(I) + V(1 + (J-1)*INCV) * C(J,I)
205+
! END DO
206+
! END DO
207+
CALL DGEMV( 'Transpose', LASTV-1, LASTC, ONE, C(2,1), LDC,
208+
$ v(1+INCV), INCV, ZERO, WORK, 1)
201209
*
202210
* w(1:lastc,1) := w(1:lastc,1) + C(1,1:lastc)**T * v(1,1)
203211
* = w(1:lastc,1) + C(1,1:lastc)**T
204212
*
213+
! Now, do w(1:lastc,1) += C(1,1:lastc)**T
214+
! DO I = 1, LASTC
215+
! WORK(I) = WORK(I) + C(1,I)
216+
! END DO
205217
CALL DAXPY(LASTC, ONE, C, LDC, WORK, 1)
206218
*
207219
* C(1:lastv,1:lastc) := C(...) - v(1:lastv,1) * w(1:lastc,1)**T

‎SRC/dorm2r.f

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -185,7 +185,7 @@ SUBROUTINE DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
185185
EXTERNAL LSAME
186186
* ..
187187
* .. External Subroutines ..
188-
EXTERNAL DLARF, XERBLA
188+
EXTERNAL DLARF, XERBLA, DLARF1
189189
* ..
190190
* .. Intrinsic Functions ..
191191
INTRINSIC MAX
@@ -268,7 +268,7 @@ SUBROUTINE DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
268268
*
269269
AII = A( I, I )
270270
A( I, I ) = ONE
271-
CALL DLARF( SIDE, MI, NI, A( I, I ), 1, TAU( I ), C( IC,
271+
CALL DLARF1( SIDE, MI, NI, A( I, I ), 1, TAU( I ), C( IC,
272272
$ JC ),
273273
$ LDC, WORK )
274274
A( I, I ) = AII

‎SRC/dormqr.f

Lines changed: 40 additions & 40 deletions
Original file line numberDiff line numberDiff line change
@@ -272,68 +272,68 @@ SUBROUTINE DORMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
272272
END IF
273273
END IF
274274
*
275-
IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN
275+
* IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN
276276
*
277277
* Use unblocked code
278278
*
279279
CALL DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
280280
$ WORK,
281281
$ IINFO )
282-
ELSE
282+
* ELSE
283283
*
284284
* Use blocked code
285285
*
286-
IWT = 1 + NW*NB
287-
IF( ( LEFT .AND. .NOT.NOTRAN ) .OR.
288-
$ ( .NOT.LEFT .AND. NOTRAN ) ) THEN
289-
I1 = 1
290-
I2 = K
291-
I3 = NB
292-
ELSE
293-
I1 = ( ( K-1 ) / NB )*NB + 1
294-
I2 = 1
295-
I3 = -NB
296-
END IF
297-
*
298-
IF( LEFT ) THEN
299-
NI = N
300-
JC = 1
301-
ELSE
302-
MI = M
303-
IC = 1
304-
END IF
305-
*
306-
DO 10 I = I1, I2, I3
307-
IB = MIN( NB, K-I+1 )
286+
! IWT = 1 + NW*NB
287+
! IF( ( LEFT .AND. .NOT.NOTRAN ) .OR.
288+
! $ ( .NOT.LEFT .AND. NOTRAN ) ) THEN
289+
! I1 = 1
290+
! I2 = K
291+
! I3 = NB
292+
! ELSE
293+
! I1 = ( ( K-1 ) / NB )*NB + 1
294+
! I2 = 1
295+
! I3 = -NB
296+
! END IF
297+
*
298+
! IF( LEFT ) THEN
299+
! NI = N
300+
! JC = 1
301+
! ELSE
302+
! MI = M
303+
! IC = 1
304+
! END IF
305+
*
306+
! DO 10 I = I1, I2, I3
307+
! IB = MIN( NB, K-I+1 )
308308
*
309309
* Form the triangular factor of the block reflector
310310
* H = H(i) H(i+1) . . . H(i+ib-1)
311311
*
312-
CALL DLARFT( 'Forward', 'Columnwise', NQ-I+1, IB, A( I,
313-
$ I ),
314-
$ LDA, TAU( I ), WORK( IWT ), LDT )
315-
IF( LEFT ) THEN
312+
! CALL DLARFT( 'Forward', 'Columnwise', NQ-I+1, IB, A( I,
313+
! $ I ),
314+
! $ LDA, TAU( I ), WORK( IWT ), LDT )
315+
! IF( LEFT ) THEN
316316
*
317317
* H or H**T is applied to C(i:m,1:n)
318318
*
319-
MI = M - I + 1
320-
IC = I
321-
ELSE
319+
! MI = M - I + 1
320+
! IC = I
321+
! ELSE
322322
*
323323
* H or H**T is applied to C(1:m,i:n)
324324
*
325-
NI = N - I + 1
326-
JC = I
327-
END IF
325+
! NI = N - I + 1
326+
! JC = I
327+
! END IF
328328
*
329329
* Apply H or H**T
330330
*
331-
CALL DLARFB( SIDE, TRANS, 'Forward', 'Columnwise', MI,
332-
$ NI,
333-
$ IB, A( I, I ), LDA, WORK( IWT ), LDT,
334-
$ C( IC, JC ), LDC, WORK, LDWORK )
335-
10 CONTINUE
336-
END IF
331+
! CALL DLARFB( SIDE, TRANS, 'Forward', 'Columnwise', MI,
332+
! $ NI,
333+
! $ IB, A( I, I ), LDA, WORK( IWT ), LDT,
334+
! $ C( IC, JC ), LDC, WORK, LDWORK )
335+
! 10 CONTINUE
336+
! END IF
337337
WORK( 1 ) = LWKOPT
338338
RETURN
339339
*

0 commit comments

Comments
 (0)