update single precision routines to use slarf1f and slarf1l, #1011

Reference-LAPACK · langou · Jun 19, 2024 · May 29, 2024 · May 30, 2024 · May 31, 2024
commit 8dd7e138a9aadc22124781499f7239c35b1ce31e
diff --git a/SRC/sgebd2.f b/SRC/sgebd2.f
@@ -209,7 +209,7 @@ SUBROUTINE SGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO )
       INTEGER            I
 *     ..
 *     .. External Subroutines ..
-      EXTERNAL           SLARF, SLARFG, XERBLA
+      EXTERNAL           SLARF1F, SLARFG, XERBLA
 *     ..
 *     .. Intrinsic Functions ..
       INTRINSIC          MAX, MIN
@@ -242,15 +242,13 @@ SUBROUTINE SGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO )
             CALL SLARFG( M-I+1, A( I, I ), A( MIN( I+1, M ), I ), 1,
      $                   TAUQ( I ) )
             D( I ) = A( I, I )
-            A( I, I ) = ONE
 *
 *           Apply H(i) to A(i:m,i+1:n) from the left
 *
             IF( I.LT.N )
-     $         CALL SLARF( 'Left', M-I+1, N-I, A( I, I ), 1,
-     $                     TAUQ( I ),
-     $                     A( I, I+1 ), LDA, WORK )
-            A( I, I ) = D( I )
+     $         CALL SLARF1F( 'Left', M-I+1, N-I, A( I, I ), 1,
+     $                       TAUQ( I ),
+     $                       A( I, I+1 ), LDA, WORK )
 *
             IF( I.LT.N ) THEN
 *
@@ -260,13 +258,11 @@ SUBROUTINE SGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO )
                CALL SLARFG( N-I, A( I, I+1 ), A( I, MIN( I+2, N ) ),
      $                      LDA, TAUP( I ) )
                E( I ) = A( I, I+1 )
-               A( I, I+1 ) = ONE
 *
 *              Apply G(i) to A(i+1:m,i+1:n) from the right
 *
-               CALL SLARF( 'Right', M-I, N-I, A( I, I+1 ), LDA,
-     $                     TAUP( I ), A( I+1, I+1 ), LDA, WORK )
-               A( I, I+1 ) = E( I )
+               CALL SLARF1F( 'Right', M-I, N-I, A( I, I+1 ), LDA,
+     $                       TAUP( I ), A( I+1, I+1 ), LDA, WORK )
             ELSE
                TAUP( I ) = ZERO
             END IF
@@ -283,14 +279,12 @@ SUBROUTINE SGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO )
      $                   LDA,
      $                   TAUP( I ) )
             D( I ) = A( I, I )
-            A( I, I ) = ONE
 *
 *           Apply G(i) to A(i+1:m,i:n) from the right
 *
             IF( I.LT.M )
-     $         CALL SLARF( 'Right', M-I, N-I+1, A( I, I ), LDA,
-     $                     TAUP( I ), A( I+1, I ), LDA, WORK )
-            A( I, I ) = D( I )
+     $         CALL SLARF1F( 'Right', M-I, N-I+1, A( I, I ), LDA,
+     $                       TAUP( I ), A( I+1, I ), LDA, WORK )
 *
             IF( I.LT.M ) THEN
 *
@@ -301,14 +295,12 @@ SUBROUTINE SGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO )
      $                      1,
      $                      TAUQ( I ) )
                E( I ) = A( I+1, I )
-               A( I+1, I ) = ONE
 *
 *              Apply H(i) to A(i+1:m,i+1:n) from the left
 *
-               CALL SLARF( 'Left', M-I, N-I, A( I+1, I ), 1,
-     $                     TAUQ( I ),
-     $                     A( I+1, I+1 ), LDA, WORK )
-               A( I+1, I ) = E( I )
+               CALL SLARF1F( 'Left', M-I, N-I, A( I+1, I ), 1,
+     $                       TAUQ( I ),
+     $                       A( I+1, I+1 ), LDA, WORK )
             ELSE
                TAUQ( I ) = ZERO
             END IF

diff --git a/SRC/sgehd2.f b/SRC/sgehd2.f
@@ -166,10 +166,9 @@ SUBROUTINE SGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO )
 *     ..
 *     .. Local Scalars ..
       INTEGER            I
-      REAL               AII
 *     ..
 *     .. External Subroutines ..
-      EXTERNAL           SLARF, SLARFG, XERBLA
+      EXTERNAL           SLARF1F, SLARFG, XERBLA
 *     ..
 *     .. Intrinsic Functions ..
       INTRINSIC          MAX, MIN
@@ -199,20 +198,17 @@ SUBROUTINE SGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO )
 *
          CALL SLARFG( IHI-I, A( I+1, I ), A( MIN( I+2, N ), I ), 1,
      $                TAU( I ) )
-         AII = A( I+1, I )
-         A( I+1, I ) = ONE
 *
 *        Apply H(i) to A(1:ihi,i+1:ihi) from the right
 *
-         CALL SLARF( 'Right', IHI, IHI-I, A( I+1, I ), 1, TAU( I ),
-     $               A( 1, I+1 ), LDA, WORK )
+         CALL SLARF1F( 'Right', IHI, IHI-I, A( I+1, I ), 1, TAU( I ),
+     $                 A( 1, I+1 ), LDA, WORK )
 *
 *        Apply H(i) to A(i+1:ihi,i+1:n) from the left
 *
-         CALL SLARF( 'Left', IHI-I, N-I, A( I+1, I ), 1, TAU( I ),
-     $               A( I+1, I+1 ), LDA, WORK )
+         CALL SLARF1F( 'Left', IHI-I, N-I, A( I+1, I ), 1, TAU( I ),
+     $                 A( I+1, I+1 ), LDA, WORK )
 *
-         A( I+1, I ) = AII
    10 CONTINUE
 *
       RETURN

diff --git a/SRC/sgelq2.f b/SRC/sgelq2.f
@@ -146,10 +146,9 @@ SUBROUTINE SGELQ2( M, N, A, LDA, TAU, WORK, INFO )
 *     ..
 *     .. Local Scalars ..
       INTEGER            I, K
-      REAL               AII
 *     ..
 *     .. External Subroutines ..
-      EXTERNAL           SLARF, SLARFG, XERBLA
+      EXTERNAL           SLARF1F, SLARFG, XERBLA
 *     ..
 *     .. Intrinsic Functions ..
       INTRINSIC          MAX, MIN
@@ -183,12 +182,9 @@ SUBROUTINE SGELQ2( M, N, A, LDA, TAU, WORK, INFO )
 *
 *           Apply H(i) to A(i+1:m,i:n) from the right
 *
-            AII = A( I, I )
-            A( I, I ) = ONE
-            CALL SLARF( 'Right', M-I, N-I+1, A( I, I ), LDA,
-     $                  TAU( I ),
-     $                  A( I+1, I ), LDA, WORK )
-            A( I, I ) = AII
+            CALL SLARF1F( 'Right', M-I, N-I+1, A( I, I ), LDA,
+     $                    TAU( I ),
+     $                    A( I+1, I ), LDA, WORK )
          END IF
    10 CONTINUE
       RETURN

diff --git a/SRC/sgeql2.f b/SRC/sgeql2.f
@@ -140,10 +140,9 @@ SUBROUTINE SGEQL2( M, N, A, LDA, TAU, WORK, INFO )
 *     ..
 *     .. Local Scalars ..
       INTEGER            I, K
-      REAL               AII
 *     ..
 *     .. External Subroutines ..
-      EXTERNAL           SLARF, SLARFG, XERBLA
+      EXTERNAL           SLARF1L, SLARFG, XERBLA
 *     ..
 *     .. Intrinsic Functions ..
       INTRINSIC          MAX, MIN
@@ -177,12 +176,9 @@ SUBROUTINE SGEQL2( M, N, A, LDA, TAU, WORK, INFO )
 *
 *        Apply H(i) to A(1:m-k+i,1:n-k+i-1) from the left
 *
-         AII = A( M-K+I, N-K+I )
-         A( M-K+I, N-K+I ) = ONE
-         CALL SLARF( 'Left', M-K+I, N-K+I-1, A( 1, N-K+I ), 1,
-     $               TAU( I ),
-     $               A, LDA, WORK )
-         A( M-K+I, N-K+I ) = AII
+         CALL SLARF1L( 'Left', M-K+I, N-K+I-1, A( 1, N-K+I ), 1,
+     $                 TAU( I ),
+     $                 A, LDA, WORK )
    10 CONTINUE
       RETURN
 *

diff --git a/SRC/sgeqp3rk.f b/SRC/sgeqp3rk.f
@@ -671,7 +671,7 @@ SUBROUTINE SGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, A, LDA,
 *           1) SGEQP3RK and SLAQP2RK: 2*N to store full and partial
 *              column 2-norms.
 *           2) SLAQP2RK: N+NRHS-1 to use in WORK array that is used
-*              in SLARF subroutine inside SLAQP2RK to apply an
+*              in SLARF1F subroutine inside SLAQP2RK to apply an
 *              elementary reflector from the left.
 *           TOTAL_WORK_SIZE = 3*N + NRHS - 1
 *
@@ -687,7 +687,7 @@ SUBROUTINE SGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, A, LDA,
 *           1) SGEQP3RK, SLAQP2RK, SLAQP3RK: 2*N to store full and
 *              partial column 2-norms.
 *           2) SLAQP2RK: N+NRHS-1 to use in WORK array that is used
-*              in SLARF subroutine to apply an elementary reflector
+*              in SLARF1F subroutine to apply an elementary reflector
 *              from the left.
 *           3) SLAQP3RK: NB*(N+NRHS) to use in the work array F that
 *              is used to apply a block reflector from

diff --git a/SRC/sgeqr2.f b/SRC/sgeqr2.f
@@ -147,10 +147,9 @@ SUBROUTINE SGEQR2( M, N, A, LDA, TAU, WORK, INFO )
 *     ..
 *     .. Local Scalars ..
       INTEGER            I, K
-      REAL               AII
 *     ..
 *     .. External Subroutines ..
-      EXTERNAL           SLARF, SLARFG, XERBLA
+      EXTERNAL           SLARF1F, SLARFG, XERBLA
 *     ..
 *     .. Intrinsic Functions ..
       INTRINSIC          MAX, MIN
@@ -184,11 +183,8 @@ SUBROUTINE SGEQR2( M, N, A, LDA, TAU, WORK, INFO )
 *
 *           Apply H(i) to A(i:m,i+1:n) from the left
 *
-            AII = A( I, I )
-            A( I, I ) = ONE
-            CALL SLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ),
-     $                  A( I, I+1 ), LDA, WORK )
-            A( I, I ) = AII
+            CALL SLARF1F( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ),
+     $                    A( I, I+1 ), LDA, WORK )
          END IF
    10 CONTINUE
       RETURN

diff --git a/SRC/sgeqr2p.f b/SRC/sgeqr2p.f
@@ -151,10 +151,9 @@ SUBROUTINE SGEQR2P( M, N, A, LDA, TAU, WORK, INFO )
 *     ..
 *     .. Local Scalars ..
       INTEGER            I, K
-      REAL               AII
 *     ..
 *     .. External Subroutines ..
-      EXTERNAL           SLARF, SLARFGP, XERBLA
+      EXTERNAL           SLARF1F, SLARFGP, XERBLA
 *     ..
 *     .. Intrinsic Functions ..
       INTRINSIC          MAX, MIN
@@ -188,11 +187,8 @@ SUBROUTINE SGEQR2P( M, N, A, LDA, TAU, WORK, INFO )
 *
 *           Apply H(i) to A(i:m,i+1:n) from the left
 *
-            AII = A( I, I )
-            A( I, I ) = ONE
-            CALL SLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ),
-     $                  A( I, I+1 ), LDA, WORK )
-            A( I, I ) = AII
+            CALL SLARF1F( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ),
+     $                    A( I, I+1 ), LDA, WORK )
          END IF
    10 CONTINUE
       RETURN

diff --git a/SRC/sgerq2.f b/SRC/sgerq2.f
@@ -140,10 +140,9 @@ SUBROUTINE SGERQ2( M, N, A, LDA, TAU, WORK, INFO )
 *     ..
 *     .. Local Scalars ..
       INTEGER            I, K
-      REAL               AII
 *     ..
 *     .. External Subroutines ..
-      EXTERNAL           SLARF, SLARFG, XERBLA
+      EXTERNAL           SLARF1L, SLARFG, XERBLA
 *     ..
 *     .. Intrinsic Functions ..
       INTRINSIC          MAX, MIN
@@ -177,11 +176,8 @@ SUBROUTINE SGERQ2( M, N, A, LDA, TAU, WORK, INFO )
 *
 *        Apply H(i) to A(1:m-k+i-1,1:n-k+i) from the right
 *
-         AII = A( M-K+I, N-K+I )
-         A( M-K+I, N-K+I ) = ONE
-         CALL SLARF( 'Right', M-K+I-1, N-K+I, A( M-K+I, 1 ), LDA,
-     $               TAU( I ), A, LDA, WORK )
-         A( M-K+I, N-K+I ) = AII
+         CALL SLARF1L( 'Right', M-K+I-1, N-K+I, A( M-K+I, 1 ), LDA,
+     $                 TAU( I ), A, LDA, WORK )
    10 CONTINUE
       RETURN
 *

diff --git a/SRC/slaqp2.f b/SRC/slaqp2.f
@@ -168,10 +168,10 @@ SUBROUTINE SLAQP2( M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2,
 *     ..
 *     .. Local Scalars ..
       INTEGER            I, ITEMP, J, MN, OFFPI, PVT
-      REAL               AII, TEMP, TEMP2, TOL3Z
+      REAL               TEMP, TEMP2, TOL3Z
 *     ..
 *     .. External Subroutines ..
-      EXTERNAL           SLARF, SLARFG, SSWAP
+      EXTERNAL           SLARF1F, SLARFG, SSWAP
 *     ..
 *     .. Intrinsic Functions ..
       INTRINSIC          ABS, MAX, MIN, SQRT
@@ -219,11 +219,8 @@ SUBROUTINE SLAQP2( M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2,
 *
 *           Apply H(i)**T to A(offset+i:m,i+1:n) from the left.
 *
-            AII = A( OFFPI, I )
-            A( OFFPI, I ) = ONE
-            CALL SLARF( 'Left', M-OFFPI+1, N-I, A( OFFPI, I ), 1,
-     $                  TAU( I ), A( OFFPI, I+1 ), LDA, WORK( 1 ) )
-            A( OFFPI, I ) = AII
+            CALL SLARF1F( 'Left', M-OFFPI+1, N-I, A( OFFPI, I ), 1,
+     $                    TAU( I ), A( OFFPI, I+1 ), LDA, WORK( 1 ) )
          END IF
 *
 *        Update partial column norms.

diff --git a/SRC/slaqp2rk.f b/SRC/slaqp2rk.f
@@ -253,7 +253,7 @@
 *> \param[out] WORK
 *> \verbatim
 *>          WORK is REAL array, dimension (N-1)
-*>          Used in SLARF subroutine to apply an elementary
+*>          Used in SLARF1F subroutine to apply an elementary
 *>          reflector from the left.
 *> \endverbatim
 *>
@@ -367,10 +367,10 @@ SUBROUTINE SLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL,
 *     .. Local Scalars ..
       INTEGER            I, ITEMP, J, JMAXC2NRM, KK, KP, MINMNFACT,
      $                   MINMNUPDT
-      REAL               AIKK, HUGEVAL, TEMP, TEMP2, TOL3Z
+      REAL               HUGEVAL, TEMP, TEMP2, TOL3Z
 *     ..
 *     .. External Subroutines ..
-      EXTERNAL           SLARF, SLARFG, SSWAP
+      EXTERNAL           SLARF1F, SLARFG, SSWAP
 *     ..
 *     .. Intrinsic Functions ..
       INTRINSIC          ABS, MAX, MIN, SQRT
@@ -621,11 +621,8 @@ SUBROUTINE SLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL,
 *         condition is satisfied, not only KK < N+NRHS )
 *
          IF( KK.LT.MINMNUPDT ) THEN
-            AIKK = A( I, KK )
-            A( I, KK ) = ONE
-            CALL SLARF( 'Left', M-I+1, N+NRHS-KK, A( I, KK ), 1,
-     $                  TAU( KK ), A( I, KK+1 ), LDA, WORK( 1 ) )
-            A( I, KK ) = AIKK
+            CALL SLARF1F( 'Left', M-I+1, N+NRHS-KK, A( I, KK ), 1,
+     $                    TAU( KK ), A( I, KK+1 ), LDA, WORK( 1 ) )
          END IF
 *
          IF( KK.LT.MINMNFACT ) THEN

diff --git a/SRC/slaqr2.f b/SRC/slaqr2.f
@@ -298,7 +298,7 @@ SUBROUTINE SLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH,
       PARAMETER          ( ZERO = 0.0e0, ONE = 1.0e0 )
 *     ..
 *     .. Local Scalars ..
-      REAL               AA, BB, BETA, CC, CS, DD, EVI, EVK, FOO, S,
+      REAL               AA, BB, CC, CS, DD, EVI, EVK, FOO, S,
      $                   SAFMAX, SAFMIN, SMLNUM, SN, TAU, ULP
       INTEGER            I, IFST, ILST, INFO, INFQR, J, JW, K, KCOL,
      $                   KEND, KLN, KROW, KWTOP, LTOP, LWK1, LWK2,
@@ -312,7 +312,8 @@ SUBROUTINE SLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH,
 *     .. External Subroutines ..
       EXTERNAL           SCOPY, SGEHRD, SGEMM, SLACPY,
      $                   SLAHQR,
-     $                   SLANV2, SLARF, SLARFG, SLASET, SORMHR, STREXC
+     $                   SLANV2, SLARF1L, SLARFG, SLASET, SORMHR,
+     $                   STREXC
 *     ..
 *     .. Intrinsic Functions ..
       INTRINSIC          ABS, INT, MAX, MIN, REAL, SQRT
@@ -595,19 +596,17 @@ SUBROUTINE SLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH,
 *           ==== Reflect spike back into lower triangle ====
 *
             CALL SCOPY( NS, V, LDV, WORK, 1 )
-            BETA = WORK( 1 )
-            CALL SLARFG( NS, BETA, WORK( 2 ), 1, TAU )
-            WORK( 1 ) = ONE
+            CALL SLARFG( NS, WORK( 1 ), WORK( 2 ), 1, TAU )
 *
             CALL SLASET( 'L', JW-2, JW-2, ZERO, ZERO, T( 3, 1 ),
      $                   LDT )
 *
-            CALL SLARF( 'L', NS, JW, WORK, 1, TAU, T, LDT,
-     $                  WORK( JW+1 ) )
-            CALL SLARF( 'R', NS, NS, WORK, 1, TAU, T, LDT,
-     $                  WORK( JW+1 ) )
-            CALL SLARF( 'R', JW, NS, WORK, 1, TAU, V, LDV,
-     $                  WORK( JW+1 ) )
+            CALL SLARF1F( 'L', NS, JW, WORK, 1, TAU, T, LDT,
+     $                    WORK( JW+1 ) )
+            CALL SLARF1F( 'R', NS, NS, WORK, 1, TAU, T, LDT,
+     $                    WORK( JW+1 ) )
+            CALL SLARF1F( 'R', JW, NS, WORK, 1, TAU, V, LDV,
+     $                    WORK( JW+1 ) )
 *
             CALL SGEHRD( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ),
      $                   LWORK-JW, INFO )