develop DLARF1F and implement in ORM2R, #1011

SRC/CMakeLists.txt

@@ -106,7 +106,7 @@ set(SLASRC
    slaqgb.f slaqge.f slaqp2.f slaqps.f slaqp2rk.f slaqp3rk.f slaqsb.f slaqsp.f slaqsy.f
    slaqr0.f slaqr1.f slaqr2.f slaqr3.f slaqr4.f slaqr5.f
    slaqtr.f slar1v.f slar2v.f ilaslr.f ilaslc.f
-   slarf.f  slarfb.f slarfb_gett.f slarfg.f slarfgp.f slarft.f slarfx.f slarfy.f
+   slarf.f  slarf1f.f slarf1l.f slarfb.f slarfb_gett.f slarfg.f slarfgp.f slarft.f slarfx.f slarfy.f
    slargv.f slarmm.f slarrv.f slartv.f
    slarz.f  slarzb.f slarzt.f slasy2.f
    slasyf.f slasyf_rook.f slasyf_rk.f slasyf_aa.f
@@ -218,7 +218,7 @@ set(CLASRC
    claqhb.f claqhe.f claqhp.f claqp2.f claqps.f claqp2rk.f claqp3rk.f claqsb.f
    claqr0.f claqr1.f claqr2.f claqr3.f claqr4.f claqr5.f
    claqsp.f claqsy.f clar1v.f clar2v.f ilaclr.f ilaclc.f
-   clarf.f  clarfb.f clarfb_gett.f clarfg.f clarfgp.f clarft.f
+   clarf.f  clarf1f.f clarf1l.f clarfb.f clarfb_gett.f clarfg.f clarfgp.f clarft.f
    clarfx.f clarfy.f clargv.f clarnv.f clarrv.f clartg.f90 clartv.f
    clarz.f  clarzb.f clarzt.f clascl.f claset.f clasr.f  classq.f90
    claswp.f clasyf.f clasyf_rook.f clasyf_rk.f clasyf_aa.f

SRC/Makefile

@@ -137,7 +137,7 @@ SLASRC = \
    slaqgb.o slaqge.o slaqp2.o slaqps.o slaqp2rk.o slaqp3rk.o slaqsb.o slaqsp.o slaqsy.o \
    slaqr0.o slaqr1.o slaqr2.o slaqr3.o slaqr4.o slaqr5.o \
    slaqtr.o slar1v.o slar2v.o ilaslr.o ilaslc.o \
-   slarf.o  slarfb.o slarfb_gett.o slarfg.o slarfgp.o slarft.o slarfx.o slarfy.o \
+   slarf.o  slarf1f.o slarf1l.o slarfb.o slarfb_gett.o slarfg.o slarfgp.o slarft.o slarfx.o slarfy.o \
    slargv.o slarmm.o slarrv.o slartv.o \
    slarz.o  slarzb.o slarzt.o slaswp.o slasy2.o slasyf.o slasyf_rook.o \
    slasyf_rk.o \
@@ -249,7 +249,7 @@ CLASRC = \
    claqhb.o claqhe.o claqhp.o claqp2.o claqps.o claqp2rk.o claqp3rk.o claqsb.o \
    claqr0.o claqr1.o claqr2.o claqr3.o claqr4.o claqr5.o \
    claqsp.o claqsy.o clar1v.o clar2v.o ilaclr.o ilaclc.o \
-   clarf.o  clarfb.o clarfb_gett.o clarfg.o clarft.o clarfgp.o \
+   clarf.o  clarf1f.o clarf1l.o clarfb.o clarfb_gett.o clarfg.o clarft.o clarfgp.o \
    clarfx.o clarfy.o clargv.o clarnv.o clarrv.o clartg.o clartv.o \
    clarz.o  clarzb.o clarzt.o clascl.o claset.o clasr.o  classq.o \
    claswp.o clasyf.o clasyf_rook.o clasyf_rk.o clasyf_aa.o \

SRC/cgebd2.f

@@ -203,16 +203,15 @@ SUBROUTINE CGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO )
 *  =====================================================================
 *
 *     .. Parameters ..
-      COMPLEX            ZERO, ONE
-      PARAMETER          ( ZERO = ( 0.0E+0, 0.0E+0 ),
-     $                   ONE = ( 1.0E+0, 0.0E+0 ) )
+      COMPLEX            ZERO
+      PARAMETER          ( ZERO = ( 0.0E+0, 0.0E+0 ) )
 *     ..
 *     .. Local Scalars ..
       INTEGER            I
       COMPLEX            ALPHA
 *     ..
 *     .. External Subroutines ..
-      EXTERNAL           CLACGV, CLARF, CLARFG, XERBLA
+      EXTERNAL           CLACGV, CLARF1F, CLARFG, XERBLA
 *     ..
 *     .. Intrinsic Functions ..
       INTRINSIC          CONJG, MAX, MIN
@@ -246,13 +245,13 @@ SUBROUTINE CGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO )
             CALL CLARFG( M-I+1, ALPHA, A( MIN( I+1, M ), I ), 1,
      $                   TAUQ( I ) )
             D( I ) = REAL( ALPHA )
-            A( I, I ) = ONE
 *
 *           Apply H(i)**H to A(i:m,i+1:n) from the left
 *
             IF( I.LT.N )
-     $         CALL CLARF( 'Left', M-I+1, N-I, A( I, I ), 1,
-     $                     CONJG( TAUQ( I ) ), A( I, I+1 ), LDA, WORK )
+     $         CALL CLARF1F( 'Left', M-I+1, N-I, A( I, I ), 1,
+     $                       CONJG( TAUQ( I ) ), A( I, I+1 ), LDA,
+     $                       WORK )
             A( I, I ) = D( I )
 *
             IF( I.LT.N ) THEN
@@ -265,12 +264,11 @@ SUBROUTINE CGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO )
                CALL CLARFG( N-I, ALPHA, A( I, MIN( I+2, N ) ),
      $                      LDA, TAUP( I ) )
                E( I ) = REAL( ALPHA )
-               A( I, I+1 ) = ONE
 *
 *              Apply G(i) to A(i+1:m,i+1:n) from the right
 *
-               CALL CLARF( 'Right', M-I, N-I, A( I, I+1 ), LDA,
-     $                     TAUP( I ), A( I+1, I+1 ), LDA, WORK )
+               CALL CLARF1F( 'Right', M-I, N-I, A( I, I+1 ), LDA,
+     $                       TAUP( I ), A( I+1, I+1 ), LDA, WORK )
                CALL CLACGV( N-I, A( I, I+1 ), LDA )
                A( I, I+1 ) = E( I )
             ELSE
@@ -290,13 +288,12 @@ SUBROUTINE CGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO )
             CALL CLARFG( N-I+1, ALPHA, A( I, MIN( I+1, N ) ), LDA,
      $                   TAUP( I ) )
             D( I ) = REAL( ALPHA )
-            A( I, I ) = ONE
 *
 *           Apply G(i) to A(i+1:m,i:n) from the right
 *
             IF( I.LT.M )
-     $         CALL CLARF( 'Right', M-I, N-I+1, A( I, I ), LDA,
-     $                     TAUP( I ), A( I+1, I ), LDA, WORK )
+     $         CALL CLARF1F( 'Right', M-I, N-I+1, A( I, I ), LDA,
+     $                       TAUP( I ), A( I+1, I ), LDA, WORK )
             CALL CLACGV( N-I+1, A( I, I ), LDA )
             A( I, I ) = D( I )
 *
@@ -309,13 +306,12 @@ SUBROUTINE CGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO )
                CALL CLARFG( M-I, ALPHA, A( MIN( I+2, M ), I ), 1,
      $                      TAUQ( I ) )
                E( I ) = REAL( ALPHA )
-               A( I+1, I ) = ONE
 *
 *              Apply H(i)**H to A(i+1:m,i+1:n) from the left
 *
-               CALL CLARF( 'Left', M-I, N-I, A( I+1, I ), 1,
-     $                     CONJG( TAUQ( I ) ), A( I+1, I+1 ), LDA,
-     $                     WORK )
+               CALL CLARF1F( 'Left', M-I, N-I, A( I+1, I ), 1,
+     $                       CONJG( TAUQ( I ) ), A( I+1, I+1 ), LDA,
+     $                       WORK )
                A( I+1, I ) = E( I )
             ELSE
                TAUQ( I ) = ZERO

SRC/cgehd2.f

@@ -160,16 +160,11 @@ SUBROUTINE CGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO )
 *
 *  =====================================================================
 *
-*     .. Parameters ..
-      COMPLEX            ONE
-      PARAMETER          ( ONE = ( 1.0E+0, 0.0E+0 ) )
-*     ..
 *     .. Local Scalars ..
       INTEGER            I
-      COMPLEX            ALPHA
 *     ..
 *     .. External Subroutines ..
-      EXTERNAL           CLARF, CLARFG, XERBLA
+      EXTERNAL           CLARF1F, CLARFG, XERBLA
 *     ..
 *     .. Intrinsic Functions ..
       INTRINSIC          CONJG, MAX, MIN
@@ -197,22 +192,19 @@ SUBROUTINE CGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO )
 *
 *        Compute elementary reflector H(i) to annihilate A(i+2:ihi,i)
 *
-         ALPHA = A( I+1, I )
-         CALL CLARFG( IHI-I, ALPHA, A( MIN( I+2, N ), I ), 1,
+         CALL CLARFG( IHI-I, A( I+1, I ), A( MIN( I+2, N ), I ), 1,
      $                TAU( I ) )
-         A( I+1, I ) = ONE
 *
 *        Apply H(i) to A(1:ihi,i+1:ihi) from the right
 *
-         CALL CLARF( 'Right', IHI, IHI-I, A( I+1, I ), 1, TAU( I ),
-     $               A( 1, I+1 ), LDA, WORK )
+         CALL CLARF1F( 'Right', IHI, IHI-I, A( I+1, I ), 1, TAU( I ),
+     $                 A( 1, I+1 ), LDA, WORK )
 *
 *        Apply H(i)**H to A(i+1:ihi,i+1:n) from the left
 *
-         CALL CLARF( 'Left', IHI-I, N-I, A( I+1, I ), 1,
-     $               CONJG( TAU( I ) ), A( I+1, I+1 ), LDA, WORK )
+         CALL CLARF1F( 'Left', IHI-I, N-I, A( I+1, I ), 1,
+     $                 CONJG( TAU( I ) ), A( I+1, I+1 ), LDA, WORK )
 *
-         A( I+1, I ) = ALPHA
    10 CONTINUE
 *
       RETURN

SRC/cgelq2.f

@@ -140,16 +140,11 @@ SUBROUTINE CGELQ2( M, N, A, LDA, TAU, WORK, INFO )
 *
 *  =====================================================================
 *
-*     .. Parameters ..
-      COMPLEX            ONE
-      PARAMETER          ( ONE = ( 1.0E+0, 0.0E+0 ) )
-*     ..
 *     .. Local Scalars ..
       INTEGER            I, K
-      COMPLEX            ALPHA
 *     ..
 *     .. External Subroutines ..
-      EXTERNAL           CLACGV, CLARF, CLARFG, XERBLA
+      EXTERNAL           CLACGV, CLARF1F, CLARFG, XERBLA
 *     ..
 *     .. Intrinsic Functions ..
       INTRINSIC          MAX, MIN
@@ -178,19 +173,15 @@ SUBROUTINE CGELQ2( M, N, A, LDA, TAU, WORK, INFO )
 *        Generate elementary reflector H(i) to annihilate A(i,i+1:n)
 *
          CALL CLACGV( N-I+1, A( I, I ), LDA )
-         ALPHA = A( I, I )
-         CALL CLARFG( N-I+1, ALPHA, A( I, MIN( I+1, N ) ), LDA,
+         CALL CLARFG( N-I+1, A( I, I ), A( I, MIN( I+1, N ) ), LDA,
      $                TAU( I ) )
          IF( I.LT.M ) THEN
 *
 *           Apply H(i) to A(i+1:m,i:n) from the right
 *
-            A( I, I ) = ONE
-            CALL CLARF( 'Right', M-I, N-I+1, A( I, I ), LDA,
-     $                  TAU( I ),
-     $                  A( I+1, I ), LDA, WORK )
+            CALL CLARF1F( 'Right', M-I, N-I+1, A( I, I ), LDA,
+     $                    TAU( I ), A( I+1, I ), LDA, WORK )
          END IF
-         A( I, I ) = ALPHA
          CALL CLACGV( N-I+1, A( I, I ), LDA )
    10 CONTINUE
       RETURN

SRC/cgeql2.f

@@ -134,16 +134,11 @@ SUBROUTINE CGEQL2( M, N, A, LDA, TAU, WORK, INFO )
 *
 *  =====================================================================
 *
-*     .. Parameters ..
-      COMPLEX            ONE
-      PARAMETER          ( ONE = ( 1.0E+0, 0.0E+0 ) )
-*     ..
 *     .. Local Scalars ..
       INTEGER            I, K
-      COMPLEX            ALPHA
 *     ..
 *     .. External Subroutines ..
-      EXTERNAL           CLARF, CLARFG, XERBLA
+      EXTERNAL           CLARF1L, CLARFG, XERBLA
 *     ..
 *     .. Intrinsic Functions ..
       INTRINSIC          CONJG, MAX, MIN
@@ -172,15 +167,13 @@ SUBROUTINE CGEQL2( M, N, A, LDA, TAU, WORK, INFO )
 *        Generate elementary reflector H(i) to annihilate
 *        A(1:m-k+i-1,n-k+i)
 *
-         ALPHA = A( M-K+I, N-K+I )
-         CALL CLARFG( M-K+I, ALPHA, A( 1, N-K+I ), 1, TAU( I ) )
+         CALL CLARFG( M-K+I, A( M-K+I, N-K+I ), A( 1, N-K+I ), 1,
+     $                TAU( I ) )
 *
 *        Apply H(i)**H to A(1:m-k+i,1:n-k+i-1) from the left
 *
-         A( M-K+I, N-K+I ) = ONE
-         CALL CLARF( 'Left', M-K+I, N-K+I-1, A( 1, N-K+I ), 1,
-     $               CONJG( TAU( I ) ), A, LDA, WORK )
-         A( M-K+I, N-K+I ) = ALPHA
+         CALL CLARF1L( 'Left', M-K+I, N-K+I-1, A( 1, N-K+I ), 1,
+     $                 CONJG( TAU( I ) ), A, LDA, WORK )
    10 CONTINUE
       RETURN
 *

SRC/cgeqp3rk.f

@@ -678,7 +678,7 @@ SUBROUTINE CGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, A, LDA,
 *           Minimal workspace size in case of using only unblocked
 *           BLAS 2 code in CLAQP2RK.
 *           1) CLAQP2RK: N+NRHS-1 to use in WORK array that is used
-*              in CLARF subroutine inside CLAQP2RK to apply an
+*              in CLARF1F subroutine inside CLAQP2RK to apply an
 *              elementary reflector from the left.
 *           TOTAL_WORK_SIZE = 3*N + NRHS - 1
 *
@@ -694,7 +694,7 @@ SUBROUTINE CGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, A, LDA,
 *           1) CGEQP3RK, CLAQP2RK, CLAQP3RK: 2*N to store full and
 *              partial column 2-norms.
 *           2) CLAQP2RK: N+NRHS-1 to use in WORK array that is used
-*              in CLARF subroutine to apply an elementary reflector
+*              in CLARF1F subroutine to apply an elementary reflector
 *              from the left.
 *           3) CLAQP3RK: NB*(N+NRHS) to use in the work array F that
 *              is used to apply a block reflector from

SRC/cgeqr2.f

@@ -141,16 +141,11 @@ SUBROUTINE CGEQR2( M, N, A, LDA, TAU, WORK, INFO )
 *
 *  =====================================================================
 *
-*     .. Parameters ..
-      COMPLEX            ONE
-      PARAMETER          ( ONE = ( 1.0E+0, 0.0E+0 ) )
-*     ..
 *     .. Local Scalars ..
       INTEGER            I, K
-      COMPLEX            ALPHA
 *     ..
 *     .. External Subroutines ..
-      EXTERNAL           CLARF, CLARFG, XERBLA
+      EXTERNAL           CLARF1F, CLARFG, XERBLA
 *     ..
 *     .. Intrinsic Functions ..
       INTRINSIC          CONJG, MAX, MIN
@@ -184,11 +179,8 @@ SUBROUTINE CGEQR2( M, N, A, LDA, TAU, WORK, INFO )
 *
 *           Apply H(i)**H to A(i:m,i+1:n) from the left
 *
-            ALPHA = A( I, I )
-            A( I, I ) = ONE
-            CALL CLARF( 'Left', M-I+1, N-I, A( I, I ), 1,
-     $                  CONJG( TAU( I ) ), A( I, I+1 ), LDA, WORK )
-            A( I, I ) = ALPHA
+            CALL CLARF1F( 'Left', M-I+1, N-I, A( I, I ), 1,
+     $                    CONJG( TAU( I ) ), A( I, I+1 ), LDA, WORK )
          END IF
    10 CONTINUE
       RETURN

SRC/cgeqr2p.f

@@ -145,16 +145,11 @@ SUBROUTINE CGEQR2P( M, N, A, LDA, TAU, WORK, INFO )
 *
 *  =====================================================================
 *
-*     .. Parameters ..
-      COMPLEX            ONE
-      PARAMETER          ( ONE = ( 1.0E+0, 0.0E+0 ) )
-*     ..
 *     .. Local Scalars ..
       INTEGER            I, K
-      COMPLEX            ALPHA
 *     ..
 *     .. External Subroutines ..
-      EXTERNAL           CLARF, CLARFGP, XERBLA
+      EXTERNAL           CLARF1F, CLARFGP, XERBLA
 *     ..
 *     .. Intrinsic Functions ..
       INTRINSIC          CONJG, MAX, MIN
@@ -188,11 +183,8 @@ SUBROUTINE CGEQR2P( M, N, A, LDA, TAU, WORK, INFO )
 *
 *           Apply H(i)**H to A(i:m,i+1:n) from the left
 *
-            ALPHA = A( I, I )
-            A( I, I ) = ONE
-            CALL CLARF( 'Left', M-I+1, N-I, A( I, I ), 1,
-     $                  CONJG( TAU( I ) ), A( I, I+1 ), LDA, WORK )
-            A( I, I ) = ALPHA
+            CALL CLARF1F( 'Left', M-I+1, N-I, A( I, I ), 1,
+     $                    CONJG( TAU( I ) ), A( I, I+1 ), LDA, WORK )
          END IF
    10 CONTINUE
       RETURN

SRC/cgerq2.f

@@ -134,16 +134,11 @@ SUBROUTINE CGERQ2( M, N, A, LDA, TAU, WORK, INFO )
 *
 *  =====================================================================
 *
-*     .. Parameters ..
-      COMPLEX            ONE
-      PARAMETER          ( ONE = ( 1.0E+0, 0.0E+0 ) )
-*     ..
 *     .. Local Scalars ..
       INTEGER            I, K
-      COMPLEX            ALPHA
 *     ..
 *     .. External Subroutines ..
-      EXTERNAL           CLACGV, CLARF, CLARFG, XERBLA
+      EXTERNAL           CLACGV, CLARF1L, CLARFG, XERBLA
 *     ..
 *     .. Intrinsic Functions ..
       INTRINSIC          MAX, MIN
@@ -173,16 +168,13 @@ SUBROUTINE CGERQ2( M, N, A, LDA, TAU, WORK, INFO )
 *        A(m-k+i,1:n-k+i-1)
 *
          CALL CLACGV( N-K+I, A( M-K+I, 1 ), LDA )
-         ALPHA = A( M-K+I, N-K+I )
-         CALL CLARFG( N-K+I, ALPHA, A( M-K+I, 1 ), LDA,
+         CALL CLARFG( N-K+I, A( M-K+I, N-K+I ), A( M-K+I, 1 ), LDA,
      $                TAU( I ) )
 *
 *        Apply H(i) to A(1:m-k+i-1,1:n-k+i) from the right
 *
-         A( M-K+I, N-K+I ) = ONE
-         CALL CLARF( '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 ) = ALPHA
+         CALL CLARF1L( 'Right', M-K+I-1, N-K+I, A( M-K+I, 1 ), LDA,
+     $                 TAU( I ), A, LDA, WORK )
          CALL CLACGV( N-K+I-1, A( M-K+I, 1 ), LDA )
    10 CONTINUE
       RETURN