diff --git a/cmake/lapack.cmake b/cmake/lapack.cmake
index a8d1c601c8..04dd49cfbe 100644
--- a/cmake/lapack.cmake
+++ b/cmake/lapack.cmake
@@ -71,7 +71,7 @@ set(SLASRC
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 slargv.f
- slarrv.f slartv.f
+ slarf1f.f slarf1l.f slarrv.f slartv.f
slarz.f slarzb.f slarzt.f slasy2.f
slasyf.f slasyf_rook.f slasyf_rk.f slasyf_aa.f
slatbs.f slatdf.f slatps.f slatrd.f slatrs.f slatrz.f
@@ -178,6 +178,7 @@ set(CLASRC
claqz0.f claqz1.f claqz2.f claqz3.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
+ clarf1f.f clarf1l.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
clasyf.f clasyf_rook.f clasyf_rk.f clasyf_aa.f
@@ -262,7 +263,7 @@ set(DLASRC
dlaqr0.f dlaqr1.f dlaqr2.f dlaqr3.f dlaqr4.f dlaqr5.f
dlaqtr.f dlar1v.f dlar2v.f iladlr.f iladlc.f
dlarf.f dlarfb.f dlarfb_gett.f dlarfg.f dlarfgp.f dlarft.f dlarfx.f dlarfy.f
- dlargv.f dlarrv.f dlartv.f
+ dlarf1f.f dlarf1l.f dlargv.f dlarrv.f dlartv.f
dlarz.f dlarzb.f dlarzt.f dlasy2.f
dlasyf.f dlasyf_rook.f dlasyf_rk.f dlasyf_aa.f
dlatbs.f dlatdf.f dlatps.f dlatrd.f dlatrs.f dlatrz.f
@@ -371,7 +372,7 @@ set(ZLASRC
zlaqr0.f zlaqr1.f zlaqr2.f zlaqr3.f zlaqr4.f zlaqr5.f
zlaqsp.f zlaqsy.f zlar1v.f zlar2v.f ilazlr.f ilazlc.f
zlarcm.f zlarf.f zlarfb.f zlarfb_gett.f
- zlarfg.f zlarfgp.f zlarft.f
+ zlarfg.f zlarfgp.f zlarft.f zlarf1f.f zlarf1l.f
zlarfx.f zlarfy.f zlargv.f zlarnv.f zlarrv.f zlartg.f90 zlartv.f
zlarz.f zlarzb.f zlarzt.f zlascl.f zlaset.f zlasr.f
zlassq.f90 zlasyf.f zlasyf_rook.f zlasyf_rk.f zlasyf_aa.f
@@ -575,7 +576,7 @@ set(SLASRC
slaqr0.c slaqr1.c slaqr2.c slaqr3.c slaqr4.c slaqr5.c
slaqtr.c slar1v.c slar2v.c ilaslr.c ilaslc.c
slarf.c slarfb.c slarfb_gett.c slarfg.c slarfgp.c slarft.c slarfx.c slarfy.c slargv.c
- slarrv.c slartv.c
+ slarf1f.c slarf1l.c slarrv.c slartv.c
slarz.c slarzb.c slarzt.c slasy2.c
slasyf.c slasyf_rook.c slasyf_rk.c slasyf_aa.c
slatbs.c slatdf.c slatps.c slatrd.c slatrs.c slatrz.c
@@ -681,6 +682,7 @@ set(CLASRC
claqr0.c claqr1.c claqr2.c claqr3.c claqr4.c claqr5.c
claqsp.c claqsy.c clar1v.c clar2v.c ilaclr.c ilaclc.c
clarf.c clarfb.c clarfb_gett.c clarfg.c clarfgp.c clarft.c
+ clarf1f.c clarf1l.c
clarfx.c clarfy.c clargv.c clarnv.c clarrv.c clartg.c clartv.c
clarz.c clarzb.c clarzt.c clascl.c claset.c clasr.c classq.c
clasyf.c clasyf_rook.c clasyf_rk.c clasyf_aa.c
@@ -764,7 +766,7 @@ set(DLASRC
dlaqr0.c dlaqr1.c dlaqr2.c dlaqr3.c dlaqr4.c dlaqr5.c
dlaqtr.c dlar1v.c dlar2v.c iladlr.c iladlc.c
dlarf.c dlarfb.c dlarfb_gett.c dlarfg.c dlarfgp.c dlarft.c dlarfx.c dlarfy.c
- dlargv.c dlarrv.c dlartv.c
+ dlarf1f.c dlarf1l.c dlargv.c dlarrv.c dlartv.c
dlarz.c dlarzb.c dlarzt.c dlasy2.c
dlasyf.c dlasyf_rook.c dlasyf_rk.c dlasyf_aa.c
dlatbs.c dlatdf.c dlatps.c dlatrd.c dlatrs.c dlatrz.c
@@ -871,7 +873,7 @@ set(ZLASRC
zlaqhb.c zlaqhe.c zlaqhp.c zlaqp2.c zlaqp2rk.c zlaqp3rk.c zlaqps.c zlaqsb.c
zlaqr0.c zlaqr1.c zlaqr2.c zlaqr3.c zlaqr4.c zlaqr5.c
zlaqsp.c zlaqsy.c zlar1v.c zlar2v.c ilazlr.c ilazlc.c
- zlarcm.c zlarf.c zlarfb.c zlarfb_gett.c
+ zlarcm.c zlarf.c zlarfb.c zlarfb_gett.c zlarf1f.c zlarf1l.c
zlarfg.c zlarfgp.c zlarft.c
zlarfx.c zlarfy.c zlargv.c zlarnv.c zlarrv.c zlartg.c zlartv.c
zlarz.c zlarzb.c zlarzt.c zlascl.c zlaset.c zlasr.c
diff --git a/lapack-netlib/SRC/Makefile b/lapack-netlib/SRC/Makefile
index 0f547dd0c4..ebf3431a92 100644
--- a/lapack-netlib/SRC/Makefile
+++ b/lapack-netlib/SRC/Makefile
@@ -155,7 +155,7 @@ SLASRC_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 slargv.o \
- slarrv.o slartv.o \
+ slarf1f.o slarf1l.o slarrv.o slartv.o \
slarz.o slarzb.o slarzt.o slaswp.o slasy2.o slasyf.o slasyf_rook.o \
slasyf_rk.o \
slatbs.o slatdf.o slatps.o slatrd.o slatrs.o slatrz.o \
@@ -271,6 +271,7 @@ CLASRC_O = \
claqsp.o claqsy.o clar1v.o clar2v.o ilaclr.o ilaclc.o \
claqz0.o claqz1.o claqz2.o claqz3.o \
clarf.o clarfb.o clarfb_gett.o clarfg.o clarft.o clarfgp.o \
+ clarf1f.o clarf1l.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 \
@@ -364,7 +365,7 @@ DLASRC_O = \
dlaqr0.o dlaqr1.o dlaqr2.o dlaqr3.o dlaqr4.o dlaqr5.o \
dlaqtr.o dlar1v.o dlar2v.o iladlr.o iladlc.o \
dlarf.o dlarfb.o dlarfb_gett.o dlarfg.o dlarfgp.o dlarft.o dlarfx.o dlarfy.o \
- dlargv.o dlarrv.o dlartv.o \
+ dlarf1f.o dlarf1l.o dlargv.o dlarrv.o dlartv.o \
dlarz.o dlarzb.o dlarzt.o dlaswp.o dlasy2.o \
dlasyf.o dlasyf_rook.o dlasyf_rk.o \
dlatbs.o dlatdf.o dlatps.o dlatrd.o dlatrs.o dlatrz.o dlauu2.o \
@@ -478,7 +479,7 @@ ZLASRC_O = \
zlaqsp.o zlaqsy.o zlar1v.o zlar2v.o ilazlr.o ilazlc.o \
zlaqz0.o zlaqz1.o zlaqz2.o zlaqz3.o \
zlarcm.o zlarf.o zlarfb.o zlarfb_gett.o \
- zlarfg.o zlarft.o zlarfgp.o \
+ zlarfg.o zlarft.o zlarfgp.o zlarf1f.o zlarf1l.o \
zlarfx.o zlarfy.o zlargv.o zlarnv.o zlarrv.o zlartg.o zlartv.o \
zlarz.o zlarzb.o zlarzt.o zlascl.o zlaset.o zlasr.o \
zlassq.o zlaswp.o zlasyf.o zlasyf_rook.o zlasyf_rk.o zlasyf_aa.o \
diff --git a/lapack-netlib/SRC/cgebd2.f b/lapack-netlib/SRC/cgebd2.f
index db949f90cf..b9be813007 100644
--- a/lapack-netlib/SRC/cgebd2.f
+++ b/lapack-netlib/SRC/cgebd2.f
@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
-*> \htmlonly
*> Download CGEBD2 + dependencies
*>
*> [TGZ]
@@ -13,7 +12,6 @@
*> [ZIP]
*>
*> [TXT]
-*> \endhtmlonly
*
* Definition:
* ===========
@@ -132,7 +130,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \ingroup complexGEcomputational
+*> \ingroup gebd2
* @precisions normal c -> s d z
*
*> \par Further Details:
@@ -187,6 +185,7 @@
*>
* =====================================================================
SUBROUTINE CGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO )
+ IMPLICIT NONE
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
@@ -203,16 +202,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 +244,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 +263,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 +287,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 +305,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
diff --git a/lapack-netlib/SRC/cgehd2.f b/lapack-netlib/SRC/cgehd2.f
index d8b40b180c..4a5400667f 100644
--- a/lapack-netlib/SRC/cgehd2.f
+++ b/lapack-netlib/SRC/cgehd2.f
@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
-*> \htmlonly
*> Download CGEHD2 + dependencies
*>
*> [TGZ]
@@ -13,7 +12,6 @@
*> [ZIP]
*>
*> [TXT]
-*> \endhtmlonly
*
* Definition:
* ===========
@@ -106,7 +104,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \ingroup complexGEcomputational
+*> \ingroup gehd2
*
*> \par Further Details:
* =====================
@@ -146,6 +144,7 @@
*>
* =====================================================================
SUBROUTINE CGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO )
+ IMPLICIT NONE
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
@@ -160,16 +159,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,21 +191,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, TAU( I ) )
- A( I+1, I ) = ONE
+ CALL CLARFG( IHI-I, A( I+1, I ), A( MIN( I+2, N ), I ), 1,
+ $ TAU( I ) )
*
* 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
diff --git a/lapack-netlib/SRC/cgelq2.f b/lapack-netlib/SRC/cgelq2.f
index 0ea4a7200f..97bc676b17 100644
--- a/lapack-netlib/SRC/cgelq2.f
+++ b/lapack-netlib/SRC/cgelq2.f
@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
-*> \htmlonly
*> Download CGELQ2 + dependencies
*>
*> [TGZ]
@@ -13,7 +12,6 @@
*> [ZIP]
*>
*> [TXT]
-*> \endhtmlonly
*
* Definition:
* ===========
@@ -104,7 +102,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \ingroup complexGEcomputational
+*> \ingroup gelq2
*
*> \par Further Details:
* =====================
@@ -126,6 +124,7 @@
*>
* =====================================================================
SUBROUTINE CGELQ2( M, N, A, LDA, TAU, WORK, INFO )
+ IMPLICIT NONE
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
@@ -140,16 +139,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,18 +172,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
diff --git a/lapack-netlib/SRC/cgeql2.f b/lapack-netlib/SRC/cgeql2.f
index 41a5f9e049..a089d267ac 100644
--- a/lapack-netlib/SRC/cgeql2.f
+++ b/lapack-netlib/SRC/cgeql2.f
@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
-*> \htmlonly
*> Download CGEQL2 + dependencies
*>
*> [TGZ]
@@ -13,7 +12,6 @@
*> [ZIP]
*>
*> [TXT]
-*> \endhtmlonly
*
* Definition:
* ===========
@@ -98,7 +96,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \ingroup complexGEcomputational
+*> \ingroup geql2
*
*> \par Further Details:
* =====================
@@ -120,6 +118,7 @@
*>
* =====================================================================
SUBROUTINE CGEQL2( M, N, A, LDA, TAU, WORK, INFO )
+ IMPLICIT NONE
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
@@ -134,16 +133,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 +166,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
*
diff --git a/lapack-netlib/SRC/cgeqp3rk.f b/lapack-netlib/SRC/cgeqp3rk.f
index fecf8d85cc..2fda980adc 100644
--- a/lapack-netlib/SRC/cgeqp3rk.f
+++ b/lapack-netlib/SRC/cgeqp3rk.f
@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
-*> \htmlonly
*> Download CGEQP3RK + dependencies
*>
*> [TGZ]
@@ -13,7 +12,6 @@
*> [ZIP]
*>
*> [TXT]
-*> \endhtmlonly
*
* Definition:
* ===========
@@ -552,27 +550,19 @@
*> C. H. Bischof, Math. and Comp. Sci. Div., Argonne National Lab, USA.
*> A BLAS-3 version of the QR factorization with column pivoting.
*> LAPACK Working Note 114
-*> \htmlonly
*> https://www.netlib.org/lapack/lawnspdf/lawn114.pdf
-*> \endhtmlonly
*> and in
*> SIAM J. Sci. Comput., 19(5):1486-1494, Sept. 1998.
-*> \htmlonly
*> https://doi.org/10.1137/S1064827595296732
-*> \endhtmlonly
*>
*> [2] A partial column norm updating strategy developed in 2006.
*> Z. Drmac and Z. Bujanovic, Dept. of Math., University of Zagreb, Croatia.
*> On the failure of rank revealing QR factorization software – a case study.
*> LAPACK Working Note 176.
-*> \htmlonly
*> http://www.netlib.org/lapack/lawnspdf/lawn176.pdf
-*> \endhtmlonly
*> and in
*> ACM Trans. Math. Softw. 35, 2, Article 12 (July 2008), 28 pages.
-*> \htmlonly
*> https://doi.org/10.1145/1377612.1377616
-*> \endhtmlonly
*
*> \par Contributors:
* ==================
@@ -678,7 +668,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 +684,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
@@ -894,7 +884,8 @@ SUBROUTINE CGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, A, LDA,
* Determine when to cross over from blocked to unblocked code.
* (for N less than NX, unblocked code should be used).
*
- NX = MAX( 0, ILAENV( IXOVER, 'CGEQP3RK', ' ', M, N, -1, -1 ) )
+ NX = MAX( 0, ILAENV( IXOVER, 'CGEQP3RK', ' ', M, N, -1,
+ $ -1 ) )
*
IF( NX.LT.MINMN ) THEN
*
diff --git a/lapack-netlib/SRC/cgeqr2.f b/lapack-netlib/SRC/cgeqr2.f
index b0b346b2db..775d33c515 100644
--- a/lapack-netlib/SRC/cgeqr2.f
+++ b/lapack-netlib/SRC/cgeqr2.f
@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
-*> \htmlonly
*> Download CGEQR2 + dependencies
*>
*> [TGZ]
@@ -13,7 +12,6 @@
*> [ZIP]
*>
*> [TXT]
-*> \endhtmlonly
*
* Definition:
* ===========
@@ -105,7 +103,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \ingroup complexGEcomputational
+*> \ingroup geqr2
*
*> \par Further Details:
* =====================
@@ -127,6 +125,7 @@
*>
* =====================================================================
SUBROUTINE CGEQR2( M, N, A, LDA, TAU, WORK, INFO )
+ IMPLICIT NONE
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
@@ -141,16 +140,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 +178,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
diff --git a/lapack-netlib/SRC/cgeqr2p.f b/lapack-netlib/SRC/cgeqr2p.f
index 7be7e7a1c9..72e3945780 100644
--- a/lapack-netlib/SRC/cgeqr2p.f
+++ b/lapack-netlib/SRC/cgeqr2p.f
@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
-*> \htmlonly
*> Download CGEQR2P + dependencies
*>
*> [TGZ]
@@ -13,7 +12,6 @@
*> [ZIP]
*>
*> [TXT]
-*> \endhtmlonly
*
* Definition:
* ===========
@@ -107,7 +105,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \ingroup complexGEcomputational
+*> \ingroup geqr2p
*
*> \par Further Details:
* =====================
@@ -131,6 +129,7 @@
*>
* =====================================================================
SUBROUTINE CGEQR2P( M, N, A, LDA, TAU, WORK, INFO )
+ IMPLICIT NONE
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
@@ -145,16 +144,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 +182,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
diff --git a/lapack-netlib/SRC/cgerq2.f b/lapack-netlib/SRC/cgerq2.f
index a2cf5cf696..3b8a959387 100644
--- a/lapack-netlib/SRC/cgerq2.f
+++ b/lapack-netlib/SRC/cgerq2.f
@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
-*> \htmlonly
*> Download CGERQ2 + dependencies
*>
*> [TGZ]
@@ -13,7 +12,6 @@
*> [ZIP]
*>
*> [TXT]
-*> \endhtmlonly
*
* Definition:
* ===========
@@ -98,7 +96,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \ingroup complexGEcomputational
+*> \ingroup gerq2
*
*> \par Further Details:
* =====================
@@ -120,6 +118,7 @@
*>
* =====================================================================
SUBROUTINE CGERQ2( M, N, A, LDA, TAU, WORK, INFO )
+ IMPLICIT NONE
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
@@ -134,16 +133,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 +167,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
diff --git a/lapack-netlib/SRC/claqp2.f b/lapack-netlib/SRC/claqp2.f
index 6e41afeb4a..ea1e4edfcb 100644
--- a/lapack-netlib/SRC/claqp2.f
+++ b/lapack-netlib/SRC/claqp2.f
@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
-*> \htmlonly
*> Download CLAQP2 + dependencies
*>
*> [TGZ]
@@ -13,7 +12,6 @@
*> [ZIP]
*>
*> [TXT]
-*> \endhtmlonly
*
* Definition:
* ===========
@@ -122,7 +120,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \ingroup complexOTHERauxiliary
+*> \ingroup laqp2
*
*> \par Contributors:
* ==================
@@ -139,13 +137,12 @@
*>
*> LAPACK Working Note 176
*
-*> \htmlonly
*> [PDF]
-*> \endhtmlonly
*
* =====================================================================
SUBROUTINE CLAQP2( M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2,
$ WORK )
+ IMPLICIT NONE
*
* -- LAPACK auxiliary routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
@@ -164,17 +161,14 @@ SUBROUTINE CLAQP2( M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2,
*
* .. Parameters ..
REAL ZERO, ONE
- COMPLEX CONE
- PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0,
- $ CONE = ( 1.0E+0, 0.0E+0 ) )
+ PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
INTEGER I, ITEMP, J, MN, OFFPI, PVT
REAL TEMP, TEMP2, TOL3Z
- COMPLEX AII
* ..
* .. External Subroutines ..
- EXTERNAL CLARF, CLARFG, CSWAP
+ EXTERNAL CLARF1F, CLARFG, CSWAP
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, CONJG, MAX, MIN, SQRT
@@ -211,7 +205,8 @@ SUBROUTINE CLAQP2( M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2,
* Generate elementary reflector H(i).
*
IF( OFFPI.LT.M ) THEN
- CALL CLARFG( M-OFFPI+1, A( OFFPI, I ), A( OFFPI+1, I ), 1,
+ CALL CLARFG( M-OFFPI+1, A( OFFPI, I ), A( OFFPI+1, I ),
+ $ 1,
$ TAU( I ) )
ELSE
CALL CLARFG( 1, A( M, I ), A( M, I ), 1, TAU( I ) )
@@ -221,12 +216,9 @@ SUBROUTINE CLAQP2( M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2,
*
* Apply H(i)**H to A(offset+i:m,i+1:n) from the left.
*
- AII = A( OFFPI, I )
- A( OFFPI, I ) = CONE
- CALL CLARF( 'Left', M-OFFPI+1, N-I, A( OFFPI, I ), 1,
- $ CONJG( TAU( I ) ), A( OFFPI, I+1 ), LDA,
- $ WORK( 1 ) )
- A( OFFPI, I ) = AII
+ CALL CLARF1F( 'Left', M-OFFPI+1, N-I, A( OFFPI, I ), 1,
+ $ CONJG( TAU( I ) ), A( OFFPI, I+1 ), LDA,
+ $ WORK( 1 ) )
END IF
*
* Update partial column norms.
diff --git a/lapack-netlib/SRC/claqp2rk.f b/lapack-netlib/SRC/claqp2rk.f
index 0501c50bb4..d27d978e95 100644
--- a/lapack-netlib/SRC/claqp2rk.f
+++ b/lapack-netlib/SRC/claqp2rk.f
@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
-*> \htmlonly
*> Download CLAQP2RK + dependencies
*>
*> [TGZ]
@@ -13,7 +12,6 @@
*> [ZIP]
*>
*> [TXT]
-*> \endhtmlonly
*
* Definition:
* ===========
@@ -254,7 +252,7 @@
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX array, dimension (N-1)
-*> Used in CLARF subroutine to apply an elementary
+*> Used in CLARF1F subroutine to apply an elementary
*> reflector from the left.
*> \endverbatim
*>
@@ -304,27 +302,19 @@
*> C. H. Bischof, Math. and Comp. Sci. Div., Argonne National Lab, USA.
*> A BLAS-3 version of the QR factorization with column pivoting.
*> LAPACK Working Note 114
-*> \htmlonly
*> https://www.netlib.org/lapack/lawnspdf/lawn114.pdf
-*> \endhtmlonly
*> and in
*> SIAM J. Sci. Comput., 19(5):1486-1494, Sept. 1998.
-*> \htmlonly
*> https://doi.org/10.1137/S1064827595296732
-*> \endhtmlonly
*>
*> [2] A partial column norm updating strategy developed in 2006.
*> Z. Drmac and Z. Bujanovic, Dept. of Math., University of Zagreb, Croatia.
*> On the failure of rank revealing QR factorization software – a case study.
*> LAPACK Working Note 176.
-*> \htmlonly
*> http://www.netlib.org/lapack/lawnspdf/lawn176.pdf
-*> \endhtmlonly
*> and in
*> ACM Trans. Math. Softw. 35, 2, Article 12 (July 2008), 28 pages.
-*> \htmlonly
*> https://doi.org/10.1145/1377612.1377616
-*> \endhtmlonly
*
*> \par Contributors:
* ==================
@@ -364,18 +354,16 @@ SUBROUTINE CLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL,
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
- COMPLEX CZERO, CONE
- PARAMETER ( CZERO = ( 0.0E+0, 0.0E+0 ),
- $ CONE = ( 1.0E+0, 0.0E+0 ) )
+ COMPLEX CZERO
+ PARAMETER ( CZERO = ( 0.0E+0, 0.0E+0 ) )
* ..
* .. Local Scalars ..
- INTEGER I, ITEMP, J, JMAXC2NRM, KK, KP, MINMNFACT,
- $ MINMNUPDT
+ INTEGER I, ITEMP, J, JMAXC2NRM, KK, KP,
+ $ KBOUND, MINMNFACT, MINMNUPDT
REAL HUGEVAL, TAUNAN, TEMP, TEMP2, TOL3Z
- COMPLEX AIKK
* ..
* .. External Subroutines ..
- EXTERNAL CLARF, CLARFG, CSWAP
+ EXTERNAL CLARF1F, CLARFG, CSWAP
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, REAL, CONJG, AIMAG, MAX, MIN, SQRT
@@ -402,13 +390,13 @@ SUBROUTINE CLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL,
*
MINMNFACT = MIN( M-IOFFSET, N )
MINMNUPDT = MIN( M-IOFFSET, N+NRHS )
- KMAX = MIN( KMAX, MINMNFACT )
+ KBOUND = MIN( KMAX, MINMNFACT )
TOL3Z = SQRT( SLAMCH( 'Epsilon' ) )
HUGEVAL = SLAMCH( 'Overflow' )
*
* Compute the factorization, KK is the lomn loop index.
*
- DO KK = 1, KMAX
+ DO KK = 1, KBOUND
*
I = IOFFSET + KK
*
@@ -633,12 +621,9 @@ SUBROUTINE CLAQP2RK( 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 ) = CONE
- CALL CLARF( 'Left', M-I+1, N+NRHS-KK, A( I, KK ), 1,
- $ CONJG( TAU( KK ) ), A( I, KK+1 ), LDA,
- $ WORK( 1 ) )
- A( I, KK ) = AIKK
+ CALL CLARF1F( 'Left', M-I+1, N+NRHS-KK, A( I, KK ), 1,
+ $ CONJG( TAU( KK ) ), A( I, KK+1 ), LDA,
+ $ WORK( 1 ) )
END IF
*
IF( KK.LT.MINMNFACT ) THEN
@@ -689,7 +674,7 @@ SUBROUTINE CLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL,
* i.e. no condition was triggered to exit the routine.
* Set the number of factorized columns.
*
- K = KMAX
+ K = KBOUND
*
* We reached the end of the loop, i.e. all KMAX columns were
* factorized, we need to set MAXC2NRMK and RELMAXC2NRMK before
diff --git a/lapack-netlib/SRC/claqr2.f b/lapack-netlib/SRC/claqr2.f
index 1695fbe5bd..22aa712349 100644
--- a/lapack-netlib/SRC/claqr2.f
+++ b/lapack-netlib/SRC/claqr2.f
@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
-*> \htmlonly
*> Download CLAQR2 + dependencies
*>
*> [TGZ]
@@ -13,7 +12,6 @@
*> [ZIP]
*>
*> [TXT]
-*> \endhtmlonly
*
* Definition:
* ===========
@@ -254,7 +252,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \ingroup complexOTHERauxiliary
+*> \ingroup laqr2
*
*> \par Contributors:
* ==================
@@ -263,9 +261,11 @@
*> University of Kansas, USA
*>
* =====================================================================
- SUBROUTINE CLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
+ SUBROUTINE CLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH,
+ $ ILOZ,
$ IHIZ, Z, LDZ, NS, ND, SH, V, LDV, NH, T, LDT,
$ NV, WV, LDWV, WORK, LWORK )
+ IMPLICIT NONE
*
* -- LAPACK auxiliary routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
@@ -291,7 +291,7 @@ SUBROUTINE CLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
PARAMETER ( RZERO = 0.0e0, RONE = 1.0e0 )
* ..
* .. Local Scalars ..
- COMPLEX BETA, CDUM, S, TAU
+ COMPLEX CDUM, S, TAU
REAL FOO, SAFMAX, SAFMIN, SMLNUM, ULP
INTEGER I, IFST, ILST, INFO, INFQR, J, JW, KCOL, KLN,
$ KNT, KROW, KWTOP, LTOP, LWK1, LWK2, LWKOPT
@@ -301,8 +301,9 @@ SUBROUTINE CLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
EXTERNAL SLAMCH
* ..
* .. External Subroutines ..
- EXTERNAL CCOPY, CGEHRD, CGEMM, CLACPY, CLAHQR, CLARF,
- $ CLARFG, CLASET, CTREXC, CUNMHR, SLABAD
+ EXTERNAL CCOPY, CGEHRD, CGEMM, CLACPY, CLAHQR,
+ $ CLARF1F,
+ $ CLARFG, CLASET, CTREXC, CUNMHR
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, AIMAG, CMPLX, CONJG, INT, MAX, MIN, REAL
@@ -329,7 +330,8 @@ SUBROUTINE CLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
*
* ==== Workspace query call to CUNMHR ====
*
- CALL CUNMHR( 'R', 'N', JW, JW, 1, JW-1, T, LDT, WORK, V, LDV,
+ CALL CUNMHR( 'R', 'N', JW, JW, 1, JW-1, T, LDT, WORK, V,
+ $ LDV,
$ WORK, -1, INFO )
LWK2 = INT( WORK( 1 ) )
*
@@ -360,7 +362,6 @@ SUBROUTINE CLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
*
SAFMIN = SLAMCH( 'SAFE MINIMUM' )
SAFMAX = RONE / SAFMIN
- CALL SLABAD( SAFMIN, SAFMAX )
ULP = SLAMCH( 'PRECISION' )
SMLNUM = SAFMIN*( REAL( N ) / ULP )
*
@@ -399,7 +400,8 @@ SUBROUTINE CLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
* . here and there to keep track.) ====
*
CALL CLACPY( 'U', JW, JW, H( KWTOP, KWTOP ), LDH, T, LDT )
- CALL CCOPY( JW-1, H( KWTOP+1, KWTOP ), LDH+1, T( 2, 1 ), LDT+1 )
+ CALL CCOPY( JW-1, H( KWTOP+1, KWTOP ), LDH+1, T( 2, 1 ),
+ $ LDT+1 )
*
CALL CLASET( 'A', JW, JW, ZERO, ONE, V, LDV )
CALL CLAHQR( .true., .true., JW, 1, JW, T, LDT, SH( KWTOP ), 1,
@@ -451,7 +453,8 @@ SUBROUTINE CLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
20 CONTINUE
ILST = I
IF( IFST.NE.ILST )
- $ CALL CTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, INFO )
+ $ CALL CTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST,
+ $ INFO )
30 CONTINUE
END IF
*
@@ -471,18 +474,17 @@ SUBROUTINE CLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
DO 50 I = 1, NS
WORK( I ) = CONJG( WORK( I ) )
50 CONTINUE
- BETA = WORK( 1 )
- CALL CLARFG( NS, BETA, WORK( 2 ), 1, TAU )
- WORK( 1 ) = ONE
+ CALL CLARFG( NS, WORK( 1 ), WORK( 2 ), 1, TAU )
*
- CALL CLASET( 'L', JW-2, JW-2, ZERO, ZERO, T( 3, 1 ), LDT )
+ CALL CLASET( 'L', JW-2, JW-2, ZERO, ZERO, T( 3, 1 ),
+ $ LDT )
*
- CALL CLARF( 'L', NS, JW, WORK, 1, CONJG( TAU ), T, LDT,
- $ WORK( JW+1 ) )
- CALL CLARF( 'R', NS, NS, WORK, 1, TAU, T, LDT,
- $ WORK( JW+1 ) )
- CALL CLARF( 'R', JW, NS, WORK, 1, TAU, V, LDV,
- $ WORK( JW+1 ) )
+ CALL CLARF1F( 'L', NS, JW, WORK, 1, CONJG( TAU ), T, LDT,
+ $ WORK( JW+1 ) )
+ CALL CLARF1F( 'R', NS, NS, WORK, 1, TAU, T, LDT,
+ $ WORK( JW+1 ) )
+ CALL CLARF1F( 'R', JW, NS, WORK, 1, TAU, V, LDV,
+ $ WORK( JW+1 ) )
*
CALL CGEHRD( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ),
$ LWORK-JW, INFO )
@@ -500,7 +502,8 @@ SUBROUTINE CLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
* . H and Z, if requested. ====
*
IF( NS.GT.1 .AND. S.NE.ZERO )
- $ CALL CUNMHR( 'R', 'N', JW, NS, 1, NS, T, LDT, WORK, V, LDV,
+ $ CALL CUNMHR( 'R', 'N', JW, NS, 1, NS, T, LDT, WORK, V,
+ $ LDV,
$ WORK( JW+1 ), LWORK-JW, INFO )
*
* ==== Update vertical slab in H ====
@@ -514,7 +517,8 @@ SUBROUTINE CLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
KLN = MIN( NV, KWTOP-KROW )
CALL CGEMM( 'N', 'N', KLN, JW, JW, ONE, H( KROW, KWTOP ),
$ LDH, V, LDV, ZERO, WV, LDWV )
- CALL CLACPY( 'A', KLN, JW, WV, LDWV, H( KROW, KWTOP ), LDH )
+ CALL CLACPY( 'A', KLN, JW, WV, LDWV, H( KROW, KWTOP ),
+ $ LDH )
60 CONTINUE
*
* ==== Update horizontal slab in H ====
@@ -534,7 +538,8 @@ SUBROUTINE CLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
IF( WANTZ ) THEN
DO 80 KROW = ILOZ, IHIZ, NV
KLN = MIN( NV, IHIZ-KROW+1 )
- CALL CGEMM( 'N', 'N', KLN, JW, JW, ONE, Z( KROW, KWTOP ),
+ CALL CGEMM( 'N', 'N', KLN, JW, JW, ONE, Z( KROW,
+ $ KWTOP ),
$ LDZ, V, LDV, ZERO, WV, LDWV )
CALL CLACPY( 'A', KLN, JW, WV, LDWV, Z( KROW, KWTOP ),
$ LDZ )
diff --git a/lapack-netlib/SRC/claqr3.f b/lapack-netlib/SRC/claqr3.f
index 2f5402de97..c0f3530c30 100644
--- a/lapack-netlib/SRC/claqr3.f
+++ b/lapack-netlib/SRC/claqr3.f
@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
-*> \htmlonly
*> Download CLAQR3 + dependencies
*>
*> [TGZ]
@@ -13,7 +12,6 @@
*> [ZIP]
*>
*> [TXT]
-*> \endhtmlonly
*
* Definition:
* ===========
@@ -251,7 +249,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \ingroup complexOTHERauxiliary
+*> \ingroup laqr3
*
*> \par Contributors:
* ==================
@@ -260,9 +258,11 @@
*> University of Kansas, USA
*>
* =====================================================================
- SUBROUTINE CLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
+ SUBROUTINE CLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH,
+ $ ILOZ,
$ IHIZ, Z, LDZ, NS, ND, SH, V, LDV, NH, T, LDT,
$ NV, WV, LDWV, WORK, LWORK )
+ IMPLICIT NONE
*
* -- LAPACK auxiliary routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
@@ -288,7 +288,7 @@ SUBROUTINE CLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
PARAMETER ( RZERO = 0.0e0, RONE = 1.0e0 )
* ..
* .. Local Scalars ..
- COMPLEX BETA, CDUM, S, TAU
+ COMPLEX CDUM, S, TAU
REAL FOO, SAFMAX, SAFMIN, SMLNUM, ULP
INTEGER I, IFST, ILST, INFO, INFQR, J, JW, KCOL, KLN,
$ KNT, KROW, KWTOP, LTOP, LWK1, LWK2, LWK3,
@@ -300,8 +300,9 @@ SUBROUTINE CLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
EXTERNAL SLAMCH, ILAENV
* ..
* .. External Subroutines ..
- EXTERNAL CCOPY, CGEHRD, CGEMM, CLACPY, CLAHQR, CLAQR4,
- $ CLARF, CLARFG, CLASET, CTREXC, CUNMHR, SLABAD
+ EXTERNAL CCOPY, CGEHRD, CGEMM, CLACPY, CLAHQR,
+ $ CLAQR4,
+ $ CLARF1F, CLARFG, CLASET, CTREXC, CUNMHR
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, AIMAG, CMPLX, CONJG, INT, MAX, MIN, REAL
@@ -328,13 +329,15 @@ SUBROUTINE CLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
*
* ==== Workspace query call to CUNMHR ====
*
- CALL CUNMHR( 'R', 'N', JW, JW, 1, JW-1, T, LDT, WORK, V, LDV,
+ CALL CUNMHR( 'R', 'N', JW, JW, 1, JW-1, T, LDT, WORK, V,
+ $ LDV,
$ WORK, -1, INFO )
LWK2 = INT( WORK( 1 ) )
*
* ==== Workspace query call to CLAQR4 ====
*
- CALL CLAQR4( .true., .true., JW, 1, JW, T, LDT, SH, 1, JW, V,
+ CALL CLAQR4( .true., .true., JW, 1, JW, T, LDT, SH, 1, JW,
+ $ V,
$ LDV, WORK, -1, INFQR )
LWK3 = INT( WORK( 1 ) )
*
@@ -365,7 +368,6 @@ SUBROUTINE CLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
*
SAFMIN = SLAMCH( 'SAFE MINIMUM' )
SAFMAX = RONE / SAFMIN
- CALL SLABAD( SAFMIN, SAFMAX )
ULP = SLAMCH( 'PRECISION' )
SMLNUM = SAFMIN*( REAL( N ) / ULP )
*
@@ -404,15 +406,18 @@ SUBROUTINE CLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
* . here and there to keep track.) ====
*
CALL CLACPY( 'U', JW, JW, H( KWTOP, KWTOP ), LDH, T, LDT )
- CALL CCOPY( JW-1, H( KWTOP+1, KWTOP ), LDH+1, T( 2, 1 ), LDT+1 )
+ CALL CCOPY( JW-1, H( KWTOP+1, KWTOP ), LDH+1, T( 2, 1 ),
+ $ LDT+1 )
*
CALL CLASET( 'A', JW, JW, ZERO, ONE, V, LDV )
NMIN = ILAENV( 12, 'CLAQR3', 'SV', JW, 1, JW, LWORK )
IF( JW.GT.NMIN ) THEN
- CALL CLAQR4( .true., .true., JW, 1, JW, T, LDT, SH( KWTOP ), 1,
+ CALL CLAQR4( .true., .true., JW, 1, JW, T, LDT, SH( KWTOP ),
+ $ 1,
$ JW, V, LDV, WORK, LWORK, INFQR )
ELSE
- CALL CLAHQR( .true., .true., JW, 1, JW, T, LDT, SH( KWTOP ), 1,
+ CALL CLAHQR( .true., .true., JW, 1, JW, T, LDT, SH( KWTOP ),
+ $ 1,
$ JW, V, LDV, INFQR )
END IF
*
@@ -462,7 +467,8 @@ SUBROUTINE CLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
20 CONTINUE
ILST = I
IF( IFST.NE.ILST )
- $ CALL CTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, INFO )
+ $ CALL CTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST,
+ $ INFO )
30 CONTINUE
END IF
*
@@ -482,18 +488,17 @@ SUBROUTINE CLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
DO 50 I = 1, NS
WORK( I ) = CONJG( WORK( I ) )
50 CONTINUE
- BETA = WORK( 1 )
- CALL CLARFG( NS, BETA, WORK( 2 ), 1, TAU )
- WORK( 1 ) = ONE
+ CALL CLARFG( NS, WORK( 1 ), WORK( 2 ), 1, TAU )
*
- CALL CLASET( 'L', JW-2, JW-2, ZERO, ZERO, T( 3, 1 ), LDT )
+ CALL CLASET( 'L', JW-2, JW-2, ZERO, ZERO, T( 3, 1 ),
+ $ LDT )
*
- CALL CLARF( 'L', NS, JW, WORK, 1, CONJG( TAU ), T, LDT,
- $ WORK( JW+1 ) )
- CALL CLARF( 'R', NS, NS, WORK, 1, TAU, T, LDT,
- $ WORK( JW+1 ) )
- CALL CLARF( 'R', JW, NS, WORK, 1, TAU, V, LDV,
- $ WORK( JW+1 ) )
+ CALL CLARF1F( 'L', NS, JW, WORK, 1, CONJG( TAU ), T, LDT,
+ $ WORK( JW+1 ) )
+ CALL CLARF1F( 'R', NS, NS, WORK, 1, TAU, T, LDT,
+ $ WORK( JW+1 ) )
+ CALL CLARF1F( 'R', JW, NS, WORK, 1, TAU, V, LDV,
+ $ WORK( JW+1 ) )
*
CALL CGEHRD( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ),
$ LWORK-JW, INFO )
@@ -511,7 +516,8 @@ SUBROUTINE CLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
* . H and Z, if requested. ====
*
IF( NS.GT.1 .AND. S.NE.ZERO )
- $ CALL CUNMHR( 'R', 'N', JW, NS, 1, NS, T, LDT, WORK, V, LDV,
+ $ CALL CUNMHR( 'R', 'N', JW, NS, 1, NS, T, LDT, WORK, V,
+ $ LDV,
$ WORK( JW+1 ), LWORK-JW, INFO )
*
* ==== Update vertical slab in H ====
@@ -525,7 +531,8 @@ SUBROUTINE CLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
KLN = MIN( NV, KWTOP-KROW )
CALL CGEMM( 'N', 'N', KLN, JW, JW, ONE, H( KROW, KWTOP ),
$ LDH, V, LDV, ZERO, WV, LDWV )
- CALL CLACPY( 'A', KLN, JW, WV, LDWV, H( KROW, KWTOP ), LDH )
+ CALL CLACPY( 'A', KLN, JW, WV, LDWV, H( KROW, KWTOP ),
+ $ LDH )
60 CONTINUE
*
* ==== Update horizontal slab in H ====
@@ -545,7 +552,8 @@ SUBROUTINE CLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
IF( WANTZ ) THEN
DO 80 KROW = ILOZ, IHIZ, NV
KLN = MIN( NV, IHIZ-KROW+1 )
- CALL CGEMM( 'N', 'N', KLN, JW, JW, ONE, Z( KROW, KWTOP ),
+ CALL CGEMM( 'N', 'N', KLN, JW, JW, ONE, Z( KROW,
+ $ KWTOP ),
$ LDZ, V, LDV, ZERO, WV, LDWV )
CALL CLACPY( 'A', KLN, JW, WV, LDWV, Z( KROW, KWTOP ),
$ LDZ )
diff --git a/lapack-netlib/SRC/clarf1f.c b/lapack-netlib/SRC/clarf1f.c
new file mode 100644
index 0000000000..1644a44489
--- /dev/null
+++ b/lapack-netlib/SRC/clarf1f.c
@@ -0,0 +1,551 @@
+#include
+#include
+#include
+#include
+#include
+#ifdef complex
+#undef complex
+#endif
+#ifdef I
+#undef I
+#endif
+
+#if defined(_WIN64)
+typedef long long BLASLONG;
+typedef unsigned long long BLASULONG;
+#else
+typedef long BLASLONG;
+typedef unsigned long BLASULONG;
+#endif
+
+#ifdef LAPACK_ILP64
+typedef BLASLONG blasint;
+#if defined(_WIN64)
+#define blasabs(x) llabs(x)
+#else
+#define blasabs(x) labs(x)
+#endif
+#else
+typedef int blasint;
+#define blasabs(x) abs(x)
+#endif
+
+typedef blasint integer;
+
+typedef unsigned int uinteger;
+typedef char *address;
+typedef short int shortint;
+typedef float real;
+typedef double doublereal;
+typedef struct { real r, i; } complex;
+typedef struct { doublereal r, i; } doublecomplex;
+#ifdef _MSC_VER
+static inline _Fcomplex Cf(complex *z) {_Fcomplex zz={z->r , z->i}; return zz;}
+static inline _Dcomplex Cd(doublecomplex *z) {_Dcomplex zz={z->r , z->i};return zz;}
+static inline _Fcomplex * _pCf(complex *z) {return (_Fcomplex*)z;}
+static inline _Dcomplex * _pCd(doublecomplex *z) {return (_Dcomplex*)z;}
+#else
+static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;}
+static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;}
+static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;}
+static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;}
+#endif
+#define pCf(z) (*_pCf(z))
+#define pCd(z) (*_pCd(z))
+typedef int logical;
+typedef short int shortlogical;
+typedef char logical1;
+typedef char integer1;
+
+#define TRUE_ (1)
+#define FALSE_ (0)
+
+/* Extern is for use with -E */
+#ifndef Extern
+#define Extern extern
+#endif
+
+/* I/O stuff */
+
+typedef int flag;
+typedef int ftnlen;
+typedef int ftnint;
+
+/*external read, write*/
+typedef struct
+{ flag cierr;
+ ftnint ciunit;
+ flag ciend;
+ char *cifmt;
+ ftnint cirec;
+} cilist;
+
+/*internal read, write*/
+typedef struct
+{ flag icierr;
+ char *iciunit;
+ flag iciend;
+ char *icifmt;
+ ftnint icirlen;
+ ftnint icirnum;
+} icilist;
+
+/*open*/
+typedef struct
+{ flag oerr;
+ ftnint ounit;
+ char *ofnm;
+ ftnlen ofnmlen;
+ char *osta;
+ char *oacc;
+ char *ofm;
+ ftnint orl;
+ char *oblnk;
+} olist;
+
+/*close*/
+typedef struct
+{ flag cerr;
+ ftnint cunit;
+ char *csta;
+} cllist;
+
+/*rewind, backspace, endfile*/
+typedef struct
+{ flag aerr;
+ ftnint aunit;
+} alist;
+
+/* inquire */
+typedef struct
+{ flag inerr;
+ ftnint inunit;
+ char *infile;
+ ftnlen infilen;
+ ftnint *inex; /*parameters in standard's order*/
+ ftnint *inopen;
+ ftnint *innum;
+ ftnint *innamed;
+ char *inname;
+ ftnlen innamlen;
+ char *inacc;
+ ftnlen inacclen;
+ char *inseq;
+ ftnlen inseqlen;
+ char *indir;
+ ftnlen indirlen;
+ char *infmt;
+ ftnlen infmtlen;
+ char *inform;
+ ftnint informlen;
+ char *inunf;
+ ftnlen inunflen;
+ ftnint *inrecl;
+ ftnint *innrec;
+ char *inblank;
+ ftnlen inblanklen;
+} inlist;
+
+#define VOID void
+
+union Multitype { /* for multiple entry points */
+ integer1 g;
+ shortint h;
+ integer i;
+ /* longint j; */
+ real r;
+ doublereal d;
+ complex c;
+ doublecomplex z;
+ };
+
+typedef union Multitype Multitype;
+
+struct Vardesc { /* for Namelist */
+ char *name;
+ char *addr;
+ ftnlen *dims;
+ int type;
+ };
+typedef struct Vardesc Vardesc;
+
+struct Namelist {
+ char *name;
+ Vardesc **vars;
+ int nvars;
+ };
+typedef struct Namelist Namelist;
+
+#define abs(x) ((x) >= 0 ? (x) : -(x))
+#define dabs(x) (fabs(x))
+#define f2cmin(a,b) ((a) <= (b) ? (a) : (b))
+#define f2cmax(a,b) ((a) >= (b) ? (a) : (b))
+#define dmin(a,b) (f2cmin(a,b))
+#define dmax(a,b) (f2cmax(a,b))
+#define bit_test(a,b) ((a) >> (b) & 1)
+#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b)))
+#define bit_set(a,b) ((a) | ((uinteger)1 << (b)))
+
+#define abort_() { sig_die("Fortran abort routine called", 1); }
+#define c_abs(z) (cabsf(Cf(z)))
+#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); }
+#ifdef _MSC_VER
+#define c_div(c, a, b) {Cf(c)._Val[0] = (Cf(a)._Val[0]/Cf(b)._Val[0]); Cf(c)._Val[1]=(Cf(a)._Val[1]/Cf(b)._Val[1]);}
+#define z_div(c, a, b) {Cd(c)._Val[0] = (Cd(a)._Val[0]/Cd(b)._Val[0]); Cd(c)._Val[1]=(Cd(a)._Val[1]/Cd(b)._Val[1]);}
+#else
+#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);}
+#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);}
+#endif
+#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));}
+#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));}
+#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));}
+//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));}
+#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));}
+#define d_abs(x) (fabs(*(x)))
+#define d_acos(x) (acos(*(x)))
+#define d_asin(x) (asin(*(x)))
+#define d_atan(x) (atan(*(x)))
+#define d_atn2(x, y) (atan2(*(x),*(y)))
+#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); }
+#define r_cnjg(R, Z) { pCf(R) = conjf(Cf(Z)); }
+#define d_cos(x) (cos(*(x)))
+#define d_cosh(x) (cosh(*(x)))
+#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 )
+#define d_exp(x) (exp(*(x)))
+#define d_imag(z) (cimag(Cd(z)))
+#define r_imag(z) (cimagf(Cf(z)))
+#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define d_log(x) (log(*(x)))
+#define d_mod(x, y) (fmod(*(x), *(y)))
+#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x)))
+#define d_nint(x) u_nint(*(x))
+#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a)))
+#define d_sign(a,b) u_sign(*(a),*(b))
+#define r_sign(a,b) u_sign(*(a),*(b))
+#define d_sin(x) (sin(*(x)))
+#define d_sinh(x) (sinh(*(x)))
+#define d_sqrt(x) (sqrt(*(x)))
+#define d_tan(x) (tan(*(x)))
+#define d_tanh(x) (tanh(*(x)))
+#define i_abs(x) abs(*(x))
+#define i_dnnt(x) ((integer)u_nint(*(x)))
+#define i_len(s, n) (n)
+#define i_nint(x) ((integer)u_nint(*(x)))
+#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b)))
+#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; }
+#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d))))
+#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
+#define sig_die(s, kill) { exit(1); }
+#define s_stop(s, n) {exit(0);}
+#define z_abs(z) (cabs(Cd(z)))
+#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
+#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
+
+/* procedure parameter types for -A and -C++ */
+
+#define F2C_proc_par_types 1
+#ifdef __cplusplus
+typedef logical (*L_fp)(...);
+#else
+typedef logical (*L_fp)();
+#endif
+
+/* Table of constant values */
+
+static complex c_b1 = {1.f,0.f};
+static complex c_b2 = {0.f,0.f};
+static integer c__1 = 1;
+
+/* > \brief \b CLARF1F applies an elementary reflector to a general rectangular */
+/* matrix assuming v(1) = 1. */
+
+/* =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/* http://www.netlib.org/lapack/explore-html/ */
+
+/* > Download CLARF1F + dependencies */
+/* > */
+/* > [TGZ] */
+/* > */
+/* > [ZIP] */
+/* > */
+/* > [TXT] */
+
+/* Definition: */
+/* =========== */
+
+/* SUBROUTINE CLARF1F( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) */
+
+/* CHARACTER SIDE */
+/* INTEGER INCV, LDC, M, N */
+/* COMPLEX TAU */
+/* COMPLEX C( LDC, * ), V( * ), WORK( * ) */
+
+
+/* > \par Purpose: */
+/* ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > CLARF1F applies a complex elementary reflector H to a complex m by n matrix */
+/* > C, from either the left or the right. H is represented in the form */
+/* > */
+/* > H = I - tau * v * v**H */
+/* > */
+/* > where tau is a complex scalar and v is a complex vector assuming v(1) = 1. */
+/* > */
+/* > If tau = 0, then H is taken to be the unit matrix. */
+/* > */
+/* > To apply H**H (the conjugate transpose of H), supply conjg(tau) instead */
+/* > tau. */
+/* > \endverbatim */
+
+/* Arguments: */
+/* ========== */
+
+/* > \param[in] SIDE */
+/* > \verbatim */
+/* > SIDE is CHARACTER*1 */
+/* > = 'L': form H * C */
+/* > = 'R': form C * H */
+/* > \endverbatim */
+/* > */
+/* > \param[in] M */
+/* > \verbatim */
+/* > M is INTEGER */
+/* > The number of rows of the matrix C. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] N */
+/* > \verbatim */
+/* > N is INTEGER */
+/* > The number of columns of the matrix C. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] V */
+/* > \verbatim */
+/* > V is COMPLEX array, dimension */
+/* > (1 + (M-1)*abs(INCV)) if SIDE = 'L' */
+/* > or (1 + (N-1)*abs(INCV)) if SIDE = 'R' */
+/* > The vector v in the representation of H. V is not used if */
+/* > TAU = 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] INCV */
+/* > \verbatim */
+/* > INCV is INTEGER */
+/* > The increment between elements of v. INCV <> 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] TAU */
+/* > \verbatim */
+/* > TAU is COMPLEX */
+/* > The value tau in the representation of H. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] C */
+/* > \verbatim */
+/* > C is COMPLEX array, dimension (LDC,N) */
+/* > On entry, the m by n matrix C. */
+/* > On exit, C is overwritten by the matrix H * C if SIDE = 'L', */
+/* > or C * H if SIDE = 'R'. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDC */
+/* > \verbatim */
+/* > LDC is INTEGER */
+/* > The leading dimension of the array C. LDC >= f2cmax(1,M). */
+/* > \endverbatim */
+/* > */
+/* > \param[out] WORK */
+/* > \verbatim */
+/* > WORK is COMPLEX array, dimension */
+/* > (N) if SIDE = 'L' */
+/* > or (M) if SIDE = 'R' */
+/* > \endverbatim */
+
+/* Authors: */
+/* ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \ingroup larf1f */
+
+/* ===================================================================== */
+/* Subroutine */ int clarf1f_(char *side, integer *m, integer *n, complex *v,
+ integer *incv, complex *tau, complex *c__, integer *ldc, complex *
+ work)
+{
+ /* System generated locals */
+ integer c_dim1, c_offset, i__1, i__2, i__3;
+ complex q__1, q__2, q__3;
+
+ /* Local variables */
+ integer i__;
+ logical applyleft;
+ extern /* Subroutine */ int cgerc_(integer *, integer *, complex *,
+ complex *, integer *, complex *, integer *, complex *, integer *),
+ cscal_(integer *, complex *, complex *, integer *), cgemv_(char *
+ , integer *, integer *, complex *, complex *, integer *, complex *
+ , integer *, complex *, complex *, integer *);
+ extern logical lsame_(char *, char *);
+ integer lastc;
+ extern /* Subroutine */ int caxpy_(integer *, complex *, complex *,
+ integer *, complex *, integer *);
+ integer lastv;
+ extern integer ilaclc_(integer *, integer *, complex *, integer *),
+ ilaclr_(integer *, integer *, complex *, integer *);
+
+
+/* -- LAPACK auxiliary routine -- */
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+
+
+/* ===================================================================== */
+
+
+ /* Parameter adjustments */
+ --v;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --work;
+
+ /* Function Body */
+ applyleft = lsame_(side, "L");
+ lastv = 1;
+ lastc = 0;
+ if (tau->r != 0.f || tau->i != 0.f) {
+/* Set up variables for scanning V. LASTV begins pointing to the end */
+/* of V up to V(1). */
+ if (applyleft) {
+ lastv = *m;
+ } else {
+ lastv = *n;
+ }
+ if (*incv > 0) {
+ i__ = (lastv - 1) * *incv + 1;
+ } else {
+ i__ = 1;
+ }
+/* Look for the last non-zero row in V. */
+ for(;;) { /* while(complicated condition) */
+ i__1 = i__;
+ if (!(lastv > 1 && (v[i__1].r == 0.f && v[i__1].i == 0.f)))
+ break;
+ --lastv;
+ i__ -= *incv;
+ }
+ if (applyleft) {
+/* Scan for the last non-zero column in C(1:lastv,:). */
+ lastc = ilaclc_(&lastv, n, &c__[c_offset], ldc);
+ } else {
+/* Scan for the last non-zero row in C(:,1:lastv). */
+ lastc = ilaclr_(m, &lastv, &c__[c_offset], ldc);
+ }
+ }
+ if (lastc == 0) {
+ return 0;
+ }
+ if (applyleft) {
+
+/* Form H * C */
+
+ if (lastv == 1) {
+
+/* C(1,1:lastc) := ( 1 - tau ) * C(1,1:lastc) */
+
+ q__1.r = 1.f - tau->r, q__1.i = 0.f - tau->i;
+ cscal_(&lastc, &q__1, &c__[c_offset], ldc);
+ } else {
+
+/* w(1:lastc,1) := C(2:lastv,1:lastc)**H * v(2:lastv,1) */
+
+ i__1 = lastv - 1;
+ cgemv_("Conjugate transpose", &i__1, &lastc, &c_b1, &c__[c_dim1 +
+ 2], ldc, &v[*incv + 1], incv, &c_b2, &work[1], &c__1);
+
+/* w(1:lastc,1) += v(1,1) * C(1,1:lastc)**H */
+
+ i__1 = lastc;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ r_cnjg(&q__2, &c__[i__ * c_dim1 + 1]);
+ q__1.r = work[i__3].r + q__2.r, q__1.i = work[i__3].i +
+ q__2.i;
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+ }
+
+/* C(1, 1:lastc) += - tau * v(1,1) * w(1:lastc,1)**H */
+
+ i__1 = lastc;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ * c_dim1 + 1;
+ i__3 = i__ * c_dim1 + 1;
+ r_cnjg(&q__3, &work[i__]);
+ q__2.r = tau->r * q__3.r - tau->i * q__3.i, q__2.i = tau->r *
+ q__3.i + tau->i * q__3.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+ }
+
+/* C(2:lastv,1:lastc) += - tau * v(2:lastv,1) * w(1:lastc,1)**H */
+
+ i__1 = lastv - 1;
+ q__1.r = -tau->r, q__1.i = -tau->i;
+ cgerc_(&i__1, &lastc, &q__1, &v[*incv + 1], incv, &work[1], &c__1,
+ &c__[c_dim1 + 2], ldc);
+ }
+ } else {
+
+/* Form C * H */
+
+ if (lastv == 1) {
+
+/* C(1:lastc,1) := ( 1 - tau ) * C(1:lastc,1) */
+
+ q__1.r = 1.f - tau->r, q__1.i = 0.f - tau->i;
+ cscal_(&lastc, &q__1, &c__[c_offset], &c__1);
+ } else {
+
+/* w(1:lastc,1) := C(1:lastc,2:lastv) * v(2:lastv,1) */
+
+ i__1 = lastv - 1;
+ cgemv_("No transpose", &lastc, &i__1, &c_b1, &c__[(c_dim1 << 1) +
+ 1], ldc, &v[*incv + 1], incv, &c_b2, &work[1], &c__1);
+
+/* w(1:lastc,1) += v(1,1) * C(1:lastc,1) */
+
+ caxpy_(&lastc, &c_b1, &c__[c_offset], &c__1, &work[1], &c__1);
+
+/* C(1:lastc,1) += - tau * v(1,1) * w(1:lastc,1) */
+
+ q__1.r = -tau->r, q__1.i = -tau->i;
+ caxpy_(&lastc, &q__1, &work[1], &c__1, &c__[c_offset], &c__1);
+
+/* C(1:lastc,2:lastv) += - tau * w(1:lastc,1) * v(2:lastv)**H */
+
+ i__1 = lastv - 1;
+ q__1.r = -tau->r, q__1.i = -tau->i;
+ cgerc_(&lastc, &i__1, &q__1, &work[1], &c__1, &v[*incv + 1], incv,
+ &c__[(c_dim1 << 1) + 1], ldc);
+ }
+ }
+ return 0;
+
+/* End of CLARF1F */
+
+} /* clarf1f_ */
+
diff --git a/lapack-netlib/SRC/clarf1f.f b/lapack-netlib/SRC/clarf1f.f
new file mode 100644
index 0000000000..cb9fc47ee1
--- /dev/null
+++ b/lapack-netlib/SRC/clarf1f.f
@@ -0,0 +1,266 @@
+*> \brief \b CLARF1F applies an elementary reflector to a general rectangular
+* matrix assuming v(1) = 1.
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> Download CLARF1F + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE CLARF1F( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )
+*
+* .. Scalar Arguments ..
+* CHARACTER SIDE
+* INTEGER INCV, LDC, M, N
+* COMPLEX TAU
+* ..
+* .. Array Arguments ..
+* COMPLEX C( LDC, * ), V( * ), WORK( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> CLARF1F applies a complex elementary reflector H to a complex m by n matrix
+*> C, from either the left or the right. H is represented in the form
+*>
+*> H = I - tau * v * v**H
+*>
+*> where tau is a complex scalar and v is a complex vector assuming v(1) = 1.
+*>
+*> If tau = 0, then H is taken to be the unit matrix.
+*>
+*> To apply H**H (the conjugate transpose of H), supply conjg(tau) instead
+*> tau.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] SIDE
+*> \verbatim
+*> SIDE is CHARACTER*1
+*> = 'L': form H * C
+*> = 'R': form C * H
+*> \endverbatim
+*>
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows of the matrix C.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of columns of the matrix C.
+*> \endverbatim
+*>
+*> \param[in] V
+*> \verbatim
+*> V is COMPLEX array, dimension
+*> (1 + (M-1)*abs(INCV)) if SIDE = 'L'
+*> or (1 + (N-1)*abs(INCV)) if SIDE = 'R'
+*> The vector v in the representation of H. V is not used if
+*> TAU = 0.
+*> \endverbatim
+*>
+*> \param[in] INCV
+*> \verbatim
+*> INCV is INTEGER
+*> The increment between elements of v. INCV <> 0.
+*> \endverbatim
+*>
+*> \param[in] TAU
+*> \verbatim
+*> TAU is COMPLEX
+*> The value tau in the representation of H.
+*> \endverbatim
+*>
+*> \param[in,out] C
+*> \verbatim
+*> C is COMPLEX array, dimension (LDC,N)
+*> On entry, the m by n matrix C.
+*> On exit, C is overwritten by the matrix H * C if SIDE = 'L',
+*> or C * H if SIDE = 'R'.
+*> \endverbatim
+*>
+*> \param[in] LDC
+*> \verbatim
+*> LDC is INTEGER
+*> The leading dimension of the array C. LDC >= max(1,M).
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is COMPLEX array, dimension
+*> (N) if SIDE = 'L'
+*> or (M) if SIDE = 'R'
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \ingroup larf1f
+*
+* =====================================================================
+ SUBROUTINE CLARF1F( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )
+ IMPLICIT NONE
+*
+* -- LAPACK auxiliary routine --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+*
+* .. Scalar Arguments ..
+ CHARACTER SIDE
+ INTEGER INCV, LDC, M, N
+ COMPLEX TAU
+* ..
+* .. Array Arguments ..
+ COMPLEX C( LDC, * ), V( * ), WORK( * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ COMPLEX ONE, ZERO
+ PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ),
+ $ ZERO = ( 0.0E+0, 0.0E+0 ) )
+* ..
+* .. Local Scalars ..
+ LOGICAL APPLYLEFT
+ INTEGER I, LASTV, LASTC
+* ..
+* .. External Subroutines ..
+ EXTERNAL CAXPY, CGEMV, CGER, CSCAL
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC CONJG
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILACLR, ILACLC
+ EXTERNAL LSAME, ILACLR, ILACLC
+* ..
+* .. Executable Statements ..
+*
+ APPLYLEFT = LSAME( SIDE, 'L' )
+ LASTV = 1
+ LASTC = 0
+ IF( TAU.NE.ZERO ) THEN
+! Set up variables for scanning V. LASTV begins pointing to the end
+! of V up to V(1).
+ IF( APPLYLEFT ) THEN
+ LASTV = M
+ ELSE
+ LASTV = N
+ END IF
+ IF( INCV.GT.0 ) THEN
+ I = 1 + (LASTV-1) * INCV
+ ELSE
+ I = 1
+ END IF
+! Look for the last non-zero row in V.
+ DO WHILE( LASTV.GT.1 .AND. V( I ).EQ.ZERO )
+ LASTV = LASTV - 1
+ I = I - INCV
+ END DO
+ IF( APPLYLEFT ) THEN
+! Scan for the last non-zero column in C(1:lastv,:).
+ LASTC = ILACLC(LASTV, N, C, LDC)
+ ELSE
+! Scan for the last non-zero row in C(:,1:lastv).
+ LASTC = ILACLR(M, LASTV, C, LDC)
+ END IF
+ END IF
+ IF( LASTC.EQ.0 ) THEN
+ RETURN
+ END IF
+ IF( APPLYLEFT ) THEN
+*
+* Form H * C
+*
+ IF( LASTV.EQ.1 ) THEN
+*
+* C(1,1:lastc) := ( 1 - tau ) * C(1,1:lastc)
+*
+ CALL CSCAL( LASTC, ONE - TAU, C, LDC )
+ ELSE
+*
+* w(1:lastc,1) := C(2:lastv,1:lastc)**H * v(2:lastv,1)
+*
+ CALL CGEMV( 'Conjugate transpose', LASTV - 1, LASTC, ONE,
+ $ C( 2, 1 ), LDC, V( 1 + INCV ), INCV, ZERO,
+ $ WORK, 1 )
+*
+* w(1:lastc,1) += v(1,1) * C(1,1:lastc)**H
+*
+ DO I = 1, LASTC
+ WORK( I ) = WORK( I ) + CONJG( C( 1, I ) )
+ END DO
+*
+* C(1, 1:lastc) += - tau * v(1,1) * w(1:lastc,1)**H
+*
+ DO I = 1, LASTC
+ C( 1, I ) = C( 1, I ) - TAU * CONJG( WORK( I ) )
+ END DO
+*
+* C(2:lastv,1:lastc) += - tau * v(2:lastv,1) * w(1:lastc,1)**H
+*
+ CALL CGERC( LASTV - 1, LASTC, -TAU, V( 1 + INCV ), INCV,
+ $ WORK, 1, C( 2, 1 ), LDC )
+ END IF
+ ELSE
+*
+* Form C * H
+*
+ IF( LASTV.EQ.1 ) THEN
+*
+* C(1:lastc,1) := ( 1 - tau ) * C(1:lastc,1)
+*
+ CALL CSCAL( LASTC, ONE - TAU, C, 1 )
+ ELSE
+*
+* w(1:lastc,1) := C(1:lastc,2:lastv) * v(2:lastv,1)
+*
+ CALL CGEMV( 'No transpose', LASTC, LASTV - 1, ONE,
+ $ C( 1, 2 ), LDC, V( 1 + INCV ), INCV, ZERO,
+ $ WORK, 1 )
+*
+* w(1:lastc,1) += v(1,1) * C(1:lastc,1)
+*
+ CALL CAXPY( LASTC, ONE, C, 1, WORK, 1 )
+*
+* C(1:lastc,1) += - tau * v(1,1) * w(1:lastc,1)
+*
+ CALL CAXPY( LASTC, -TAU, WORK, 1, C, 1 )
+*
+* C(1:lastc,2:lastv) += - tau * w(1:lastc,1) * v(2:lastv)**H
+*
+ CALL CGERC( LASTC, LASTV - 1, -TAU, WORK, 1,
+ $ V( 1 + INCV ), INCV, C( 1, 2 ), LDC )
+ END IF
+ END IF
+ RETURN
+*
+* End of CLARF1F
+*
+ END
diff --git a/lapack-netlib/SRC/clarf1l.c b/lapack-netlib/SRC/clarf1l.c
new file mode 100644
index 0000000000..054d6416fd
--- /dev/null
+++ b/lapack-netlib/SRC/clarf1l.c
@@ -0,0 +1,551 @@
+#include
+#include
+#include
+#include
+#include
+#ifdef complex
+#undef complex
+#endif
+#ifdef I
+#undef I
+#endif
+
+#if defined(_WIN64)
+typedef long long BLASLONG;
+typedef unsigned long long BLASULONG;
+#else
+typedef long BLASLONG;
+typedef unsigned long BLASULONG;
+#endif
+
+#ifdef LAPACK_ILP64
+typedef BLASLONG blasint;
+#if defined(_WIN64)
+#define blasabs(x) llabs(x)
+#else
+#define blasabs(x) labs(x)
+#endif
+#else
+typedef int blasint;
+#define blasabs(x) abs(x)
+#endif
+
+typedef blasint integer;
+
+typedef unsigned int uinteger;
+typedef char *address;
+typedef short int shortint;
+typedef float real;
+typedef double doublereal;
+typedef struct { real r, i; } complex;
+typedef struct { doublereal r, i; } doublecomplex;
+#ifdef _MSC_VER
+static inline _Fcomplex Cf(complex *z) {_Fcomplex zz={z->r , z->i}; return zz;}
+static inline _Dcomplex Cd(doublecomplex *z) {_Dcomplex zz={z->r , z->i};return zz;}
+static inline _Fcomplex * _pCf(complex *z) {return (_Fcomplex*)z;}
+static inline _Dcomplex * _pCd(doublecomplex *z) {return (_Dcomplex*)z;}
+#else
+static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;}
+static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;}
+static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;}
+static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;}
+#endif
+#define pCf(z) (*_pCf(z))
+#define pCd(z) (*_pCd(z))
+typedef int logical;
+typedef short int shortlogical;
+typedef char logical1;
+typedef char integer1;
+
+#define TRUE_ (1)
+#define FALSE_ (0)
+
+/* Extern is for use with -E */
+#ifndef Extern
+#define Extern extern
+#endif
+
+/* I/O stuff */
+
+typedef int flag;
+typedef int ftnlen;
+typedef int ftnint;
+
+/*external read, write*/
+typedef struct
+{ flag cierr;
+ ftnint ciunit;
+ flag ciend;
+ char *cifmt;
+ ftnint cirec;
+} cilist;
+
+/*internal read, write*/
+typedef struct
+{ flag icierr;
+ char *iciunit;
+ flag iciend;
+ char *icifmt;
+ ftnint icirlen;
+ ftnint icirnum;
+} icilist;
+
+/*open*/
+typedef struct
+{ flag oerr;
+ ftnint ounit;
+ char *ofnm;
+ ftnlen ofnmlen;
+ char *osta;
+ char *oacc;
+ char *ofm;
+ ftnint orl;
+ char *oblnk;
+} olist;
+
+/*close*/
+typedef struct
+{ flag cerr;
+ ftnint cunit;
+ char *csta;
+} cllist;
+
+/*rewind, backspace, endfile*/
+typedef struct
+{ flag aerr;
+ ftnint aunit;
+} alist;
+
+/* inquire */
+typedef struct
+{ flag inerr;
+ ftnint inunit;
+ char *infile;
+ ftnlen infilen;
+ ftnint *inex; /*parameters in standard's order*/
+ ftnint *inopen;
+ ftnint *innum;
+ ftnint *innamed;
+ char *inname;
+ ftnlen innamlen;
+ char *inacc;
+ ftnlen inacclen;
+ char *inseq;
+ ftnlen inseqlen;
+ char *indir;
+ ftnlen indirlen;
+ char *infmt;
+ ftnlen infmtlen;
+ char *inform;
+ ftnint informlen;
+ char *inunf;
+ ftnlen inunflen;
+ ftnint *inrecl;
+ ftnint *innrec;
+ char *inblank;
+ ftnlen inblanklen;
+} inlist;
+
+#define VOID void
+
+union Multitype { /* for multiple entry points */
+ integer1 g;
+ shortint h;
+ integer i;
+ /* longint j; */
+ real r;
+ doublereal d;
+ complex c;
+ doublecomplex z;
+ };
+
+typedef union Multitype Multitype;
+
+struct Vardesc { /* for Namelist */
+ char *name;
+ char *addr;
+ ftnlen *dims;
+ int type;
+ };
+typedef struct Vardesc Vardesc;
+
+struct Namelist {
+ char *name;
+ Vardesc **vars;
+ int nvars;
+ };
+typedef struct Namelist Namelist;
+
+#define abs(x) ((x) >= 0 ? (x) : -(x))
+#define dabs(x) (fabs(x))
+#define f2cmin(a,b) ((a) <= (b) ? (a) : (b))
+#define f2cmax(a,b) ((a) >= (b) ? (a) : (b))
+#define dmin(a,b) (f2cmin(a,b))
+#define dmax(a,b) (f2cmax(a,b))
+#define bit_test(a,b) ((a) >> (b) & 1)
+#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b)))
+#define bit_set(a,b) ((a) | ((uinteger)1 << (b)))
+
+#define abort_() { sig_die("Fortran abort routine called", 1); }
+#define c_abs(z) (cabsf(Cf(z)))
+#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); }
+#ifdef _MSC_VER
+#define c_div(c, a, b) {Cf(c)._Val[0] = (Cf(a)._Val[0]/Cf(b)._Val[0]); Cf(c)._Val[1]=(Cf(a)._Val[1]/Cf(b)._Val[1]);}
+#define z_div(c, a, b) {Cd(c)._Val[0] = (Cd(a)._Val[0]/Cd(b)._Val[0]); Cd(c)._Val[1]=(Cd(a)._Val[1]/Cd(b)._Val[1]);}
+#else
+#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);}
+#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);}
+#endif
+#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));}
+#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));}
+#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));}
+//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));}
+#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));}
+#define d_abs(x) (fabs(*(x)))
+#define d_acos(x) (acos(*(x)))
+#define d_asin(x) (asin(*(x)))
+#define d_atan(x) (atan(*(x)))
+#define d_atn2(x, y) (atan2(*(x),*(y)))
+#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); }
+#define r_cnjg(R, Z) { pCf(R) = conjf(Cf(Z)); }
+#define d_cos(x) (cos(*(x)))
+#define d_cosh(x) (cosh(*(x)))
+#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 )
+#define d_exp(x) (exp(*(x)))
+#define d_imag(z) (cimag(Cd(z)))
+#define r_imag(z) (cimagf(Cf(z)))
+#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define d_log(x) (log(*(x)))
+#define d_mod(x, y) (fmod(*(x), *(y)))
+#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x)))
+#define d_nint(x) u_nint(*(x))
+#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a)))
+#define d_sign(a,b) u_sign(*(a),*(b))
+#define r_sign(a,b) u_sign(*(a),*(b))
+#define d_sin(x) (sin(*(x)))
+#define d_sinh(x) (sinh(*(x)))
+#define d_sqrt(x) (sqrt(*(x)))
+#define d_tan(x) (tan(*(x)))
+#define d_tanh(x) (tanh(*(x)))
+#define i_abs(x) abs(*(x))
+#define i_dnnt(x) ((integer)u_nint(*(x)))
+#define i_len(s, n) (n)
+#define i_nint(x) ((integer)u_nint(*(x)))
+#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b)))
+#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; }
+#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d))))
+#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
+#define sig_die(s, kill) { exit(1); }
+#define s_stop(s, n) {exit(0);}
+#define z_abs(z) (cabs(Cd(z)))
+#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
+#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
+
+/* procedure parameter types for -A and -C++ */
+
+#define F2C_proc_par_types 1
+#ifdef __cplusplus
+typedef logical (*L_fp)(...);
+#else
+typedef logical (*L_fp)();
+#endif
+
+/* Table of constant values */
+
+static complex c_b1 = {1.f,0.f};
+static complex c_b2 = {0.f,0.f};
+static integer c__1 = 1;
+
+/* > \brief \b CLARF1L applies an elementary reflector to a general rectangular */
+/* matrix assuming v(lastv) = 1, where lastv is the last non-zero */
+
+/* =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/* http://www.netlib.org/lapack/explore-html/ */
+
+/* > Download CLARF1L + dependencies */
+/* > */
+/* > [TGZ] */
+/* > */
+/* > [ZIP] */
+/* > */
+/* > [TXT] */
+
+/* Definition: */
+/* =========== */
+
+/* SUBROUTINE CLARF1L( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) */
+
+/* CHARACTER SIDE */
+/* INTEGER INCV, LDC, M, N */
+/* COMPLEX TAU */
+/* COMPLEX C( LDC, * ), V( * ), WORK( * ) */
+
+
+/* > \par Purpose: */
+/* ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > CLARF1L applies a complex elementary reflector H to a complex m by n matrix */
+/* > C, from either the left or the right. H is represented in the form */
+/* > */
+/* > H = I - tau * v * v**H */
+/* > */
+/* > where tau is a real scalar and v is a real vector assuming v(lastv) = 1, */
+/* > where lastv is the last non-zero element. */
+/* > */
+/* > If tau = 0, then H is taken to be the unit matrix. */
+/* > */
+/* > To apply H**H (the conjugate transpose of H), supply conjg(tau) instead */
+/* > tau. */
+/* > \endverbatim */
+
+/* Arguments: */
+/* ========== */
+
+/* > \param[in] SIDE */
+/* > \verbatim */
+/* > SIDE is CHARACTER*1 */
+/* > = 'L': form H * C */
+/* > = 'R': form C * H */
+/* > \endverbatim */
+/* > */
+/* > \param[in] M */
+/* > \verbatim */
+/* > M is INTEGER */
+/* > The number of rows of the matrix C. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] N */
+/* > \verbatim */
+/* > N is INTEGER */
+/* > The number of columns of the matrix C. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] V */
+/* > \verbatim */
+/* > V is COMPLEX array, dimension */
+/* > (1 + (M-1)*abs(INCV)) if SIDE = 'L' */
+/* > or (1 + (N-1)*abs(INCV)) if SIDE = 'R' */
+/* > The vector v in the representation of H. V is not used if */
+/* > TAU = 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] INCV */
+/* > \verbatim */
+/* > INCV is INTEGER */
+/* > The increment between elements of v. INCV > 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] TAU */
+/* > \verbatim */
+/* > TAU is COMPLEX */
+/* > The value tau in the representation of H. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] C */
+/* > \verbatim */
+/* > C is COMPLEX array, dimension (LDC,N) */
+/* > On entry, the m by n matrix C. */
+/* > On exit, C is overwritten by the matrix H * C if SIDE = 'L', */
+/* > or C * H if SIDE = 'R'. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDC */
+/* > \verbatim */
+/* > LDC is INTEGER */
+/* > The leading dimension of the array C. LDC >= f2cmax(1,M). */
+/* > \endverbatim */
+/* > */
+/* > \param[out] WORK */
+/* > \verbatim */
+/* > WORK is COMPLEX array, dimension */
+/* > (N) if SIDE = 'L' */
+/* > or (M) if SIDE = 'R' */
+/* > \endverbatim */
+
+/* Authors: */
+/* ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \ingroup larf1f */
+
+/* ===================================================================== */
+/* Subroutine */ int clarf1l_(char *side, integer *m, integer *n, complex *v,
+ integer *incv, complex *tau, complex *c__, integer *ldc, complex *
+ work)
+{
+ /* System generated locals */
+ integer c_dim1, c_offset, i__1, i__2, i__3;
+ complex q__1, q__2, q__3;
+
+ /* Local variables */
+ integer i__, j;
+ logical applyleft;
+ extern /* Subroutine */ int cgerc_(integer *, integer *, complex *,
+ complex *, integer *, complex *, integer *, complex *, integer *),
+ cscal_(integer *, complex *, complex *, integer *), cgemv_(char *
+ , integer *, integer *, complex *, complex *, integer *, complex *
+ , integer *, complex *, complex *, integer *);
+ extern logical lsame_(char *, char *);
+ integer lastc;
+ extern /* Subroutine */ int caxpy_(integer *, complex *, complex *,
+ integer *, complex *, integer *);
+ integer lastv;
+ extern integer ilaclc_(integer *, integer *, complex *, integer *),
+ ilaclr_(integer *, integer *, complex *, integer *);
+ integer firstv;
+
+
+/* -- LAPACK auxiliary routine -- */
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+
+
+/* ===================================================================== */
+
+
+ /* Parameter adjustments */
+ --v;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --work;
+
+ /* Function Body */
+ applyleft = lsame_(side, "L");
+ firstv = 1;
+ lastc = 0;
+ if (tau->r != 0.f || tau->i != 0.f) {
+/* Set up variables for scanning V. LASTV begins pointing to the end */
+/* of V up to V(1). */
+ if (applyleft) {
+ lastv = *m;
+ } else {
+ lastv = *n;
+ }
+ i__ = 1;
+/* Look for the last non-zero row in V. */
+ for(;;) { /* while(complicated condition) */
+ i__1 = i__;
+ if (!(lastv > firstv && (v[i__1].r == 0.f && v[i__1].i == 0.f)))
+ break;
+ ++firstv;
+ i__ += *incv;
+ }
+ if (applyleft) {
+/* Scan for the last non-zero column in C(1:lastv,:). */
+ lastc = ilaclc_(&lastv, n, &c__[c_offset], ldc);
+ } else {
+/* Scan for the last non-zero row in C(:,1:lastv). */
+ lastc = ilaclr_(m, &lastv, &c__[c_offset], ldc);
+ }
+ }
+ if (lastc == 0) {
+ return 0;
+ }
+ if (applyleft) {
+
+/* Form H * C */
+
+ if (lastv == firstv) {
+
+/* C(lastv,1:lastc) := ( 1 - tau ) * C(lastv,1:lastc) */
+
+ q__1.r = 1.f - tau->r, q__1.i = 0.f - tau->i;
+ cscal_(&lastc, &q__1, &c__[lastv + c_dim1], ldc);
+ } else {
+
+/* w(1:lastc,1) := C(firstv:lastv-1,1:lastc)**T * v(firstv:lastv-1,1) */
+
+ i__1 = lastv - firstv;
+ cgemv_("Conjugate transpose", &i__1, &lastc, &c_b1, &c__[firstv +
+ c_dim1], ldc, &v[i__], incv, &c_b2, &work[1], &c__1);
+
+/* w(1:lastc,1) += C(lastv,1:lastc)**H * v(lastv,1) */
+
+ i__1 = lastc;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ i__3 = j;
+ r_cnjg(&q__2, &c__[lastv + j * c_dim1]);
+ q__1.r = work[i__3].r + q__2.r, q__1.i = work[i__3].i +
+ q__2.i;
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+ }
+
+/* C(lastv,1:lastc) += - tau * v(lastv,1) * w(1:lastc,1)**H */
+
+ i__1 = lastc;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = lastv + j * c_dim1;
+ i__3 = lastv + j * c_dim1;
+ r_cnjg(&q__3, &work[j]);
+ q__2.r = tau->r * q__3.r - tau->i * q__3.i, q__2.i = tau->r *
+ q__3.i + tau->i * q__3.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+ }
+
+/* C(firstv:lastv-1,1:lastc) += - tau * v(firstv:lastv-1,1) * w(1:lastc,1)**H */
+
+ i__1 = lastv - firstv;
+ q__1.r = -tau->r, q__1.i = -tau->i;
+ cgerc_(&i__1, &lastc, &q__1, &v[i__], incv, &work[1], &c__1, &c__[
+ firstv + c_dim1], ldc);
+ }
+ } else {
+
+/* Form C * H */
+
+ if (lastv == firstv) {
+
+/* C(1:lastc,lastv) := ( 1 - tau ) * C(1:lastc,lastv) */
+
+ q__1.r = 1.f - tau->r, q__1.i = 0.f - tau->i;
+ cscal_(&lastc, &q__1, &c__[lastv * c_dim1 + 1], &c__1);
+ } else {
+
+/* w(1:lastc,1) := C(1:lastc,firstv:lastv-1) * v(firstv:lastv-1,1) */
+
+ i__1 = lastv - firstv;
+ cgemv_("No transpose", &lastc, &i__1, &c_b1, &c__[firstv * c_dim1
+ + 1], ldc, &v[i__], incv, &c_b2, &work[1], &c__1);
+
+/* w(1:lastc,1) += C(1:lastc,lastv) * v(lastv,1) */
+
+ caxpy_(&lastc, &c_b1, &c__[lastv * c_dim1 + 1], &c__1, &work[1], &
+ c__1);
+
+/* C(1:lastc,lastv) += - tau * v(lastv,1) * w(1:lastc,1) */
+
+ q__1.r = -tau->r, q__1.i = -tau->i;
+ caxpy_(&lastc, &q__1, &work[1], &c__1, &c__[lastv * c_dim1 + 1], &
+ c__1);
+
+/* C(1:lastc,firstv:lastv-1) += - tau * w(1:lastc,1) * v(firstv:lastv-1)**H */
+
+ i__1 = lastv - firstv;
+ q__1.r = -tau->r, q__1.i = -tau->i;
+ cgerc_(&lastc, &i__1, &q__1, &work[1], &c__1, &v[i__], incv, &c__[
+ firstv * c_dim1 + 1], ldc);
+ }
+ }
+ return 0;
+
+/* End of CLARF1L */
+
+} /* clarf1l_ */
+
diff --git a/lapack-netlib/SRC/clarf1l.f b/lapack-netlib/SRC/clarf1l.f
new file mode 100644
index 0000000000..a592255f16
--- /dev/null
+++ b/lapack-netlib/SRC/clarf1l.f
@@ -0,0 +1,264 @@
+*> \brief \b CLARF1L applies an elementary reflector to a general rectangular
+* matrix assuming v(lastv) = 1, where lastv is the last non-zero
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> Download CLARF1L + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE CLARF1L( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )
+*
+* .. Scalar Arguments ..
+* CHARACTER SIDE
+* INTEGER INCV, LDC, M, N
+* COMPLEX TAU
+* ..
+* .. Array Arguments ..
+* COMPLEX C( LDC, * ), V( * ), WORK( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> CLARF1L applies a complex elementary reflector H to a complex m by n matrix
+*> C, from either the left or the right. H is represented in the form
+*>
+*> H = I - tau * v * v**H
+*>
+*> where tau is a real scalar and v is a real vector assuming v(lastv) = 1,
+*> where lastv is the last non-zero element.
+*>
+*> If tau = 0, then H is taken to be the unit matrix.
+*>
+*> To apply H**H (the conjugate transpose of H), supply conjg(tau) instead
+*> tau.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] SIDE
+*> \verbatim
+*> SIDE is CHARACTER*1
+*> = 'L': form H * C
+*> = 'R': form C * H
+*> \endverbatim
+*>
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows of the matrix C.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of columns of the matrix C.
+*> \endverbatim
+*>
+*> \param[in] V
+*> \verbatim
+*> V is COMPLEX array, dimension
+*> (1 + (M-1)*abs(INCV)) if SIDE = 'L'
+*> or (1 + (N-1)*abs(INCV)) if SIDE = 'R'
+*> The vector v in the representation of H. V is not used if
+*> TAU = 0.
+*> \endverbatim
+*>
+*> \param[in] INCV
+*> \verbatim
+*> INCV is INTEGER
+*> The increment between elements of v. INCV > 0.
+*> \endverbatim
+*>
+*> \param[in] TAU
+*> \verbatim
+*> TAU is COMPLEX
+*> The value tau in the representation of H.
+*> \endverbatim
+*>
+*> \param[in,out] C
+*> \verbatim
+*> C is COMPLEX array, dimension (LDC,N)
+*> On entry, the m by n matrix C.
+*> On exit, C is overwritten by the matrix H * C if SIDE = 'L',
+*> or C * H if SIDE = 'R'.
+*> \endverbatim
+*>
+*> \param[in] LDC
+*> \verbatim
+*> LDC is INTEGER
+*> The leading dimension of the array C. LDC >= max(1,M).
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is COMPLEX array, dimension
+*> (N) if SIDE = 'L'
+*> or (M) if SIDE = 'R'
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \ingroup larf1f
+*
+* =====================================================================
+ SUBROUTINE CLARF1L( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )
+ IMPLICIT NONE
+*
+* -- LAPACK auxiliary routine --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+*
+* .. Scalar Arguments ..
+ CHARACTER SIDE
+ INTEGER INCV, LDC, M, N
+ COMPLEX TAU
+* ..
+* .. Array Arguments ..
+ COMPLEX C( LDC, * ), V( * ), WORK( * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ COMPLEX ONE, ZERO
+ PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ),
+ $ ZERO = ( 0.0E+0, 0.0E+0 ) )
+* ..
+* .. Local Scalars ..
+ LOGICAL APPLYLEFT
+ INTEGER I, J, LASTV, LASTC, FIRSTV
+* ..
+* .. External Subroutines ..
+ EXTERNAL CAXPY, CGEMV, CGERC, CSCAL
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC CONJG
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILACLR, ILACLC
+ EXTERNAL LSAME, ILACLR, ILACLC
+* ..
+* .. Executable Statements ..
+*
+ APPLYLEFT = LSAME( SIDE, 'L' )
+ FIRSTV = 1
+ LASTC = 0
+ IF( TAU.NE.ZERO ) THEN
+! Set up variables for scanning V. LASTV begins pointing to the end
+! of V up to V(1).
+ IF( APPLYLEFT ) THEN
+ LASTV = M
+ ELSE
+ LASTV = N
+ END IF
+ I = 1
+! Look for the last non-zero row in V.
+ DO WHILE( LASTV.GT.FIRSTV .AND. V( I ).EQ.ZERO )
+ FIRSTV = FIRSTV + 1
+ I = I + INCV
+ END DO
+ IF( APPLYLEFT ) THEN
+! Scan for the last non-zero column in C(1:lastv,:).
+ LASTC = ILACLC(LASTV, N, C, LDC)
+ ELSE
+! Scan for the last non-zero row in C(:,1:lastv).
+ LASTC = ILACLR(M, LASTV, C, LDC)
+ END IF
+ END IF
+ IF( LASTC.EQ.0 ) THEN
+ RETURN
+ END IF
+ IF( APPLYLEFT ) THEN
+*
+* Form H * C
+*
+ IF( LASTV.EQ.FIRSTV ) THEN
+*
+* C(lastv,1:lastc) := ( 1 - tau ) * C(lastv,1:lastc)
+*
+ CALL CSCAL( LASTC, ONE - TAU, C( LASTV, 1 ), LDC )
+ ELSE
+*
+* w(1:lastc,1) := C(firstv:lastv-1,1:lastc)**T * v(firstv:lastv-1,1)
+*
+ CALL CGEMV( 'Conjugate transpose', LASTV - FIRSTV, LASTC,
+ $ ONE, C( FIRSTV, 1 ), LDC, V( I ), INCV, ZERO,
+ $ WORK, 1 )
+*
+* w(1:lastc,1) += C(lastv,1:lastc)**H * v(lastv,1)
+*
+ DO J = 1, LASTC
+ WORK( J ) = WORK( J ) + CONJG( C( LASTV, J ) )
+ END DO
+*
+* C(lastv,1:lastc) += - tau * v(lastv,1) * w(1:lastc,1)**H
+*
+ DO J = 1, LASTC
+ C( LASTV, J ) = C( LASTV, J )
+ $ - TAU * CONJG( WORK( J ) )
+ END DO
+*
+* C(firstv:lastv-1,1:lastc) += - tau * v(firstv:lastv-1,1) * w(1:lastc,1)**H
+*
+ CALL CGERC( LASTV - FIRSTV, LASTC, -TAU, V( I ), INCV,
+ $ WORK, 1, C( FIRSTV, 1 ), LDC)
+ END IF
+ ELSE
+*
+* Form C * H
+*
+ IF( LASTV.EQ.FIRSTV ) THEN
+*
+* C(1:lastc,lastv) := ( 1 - tau ) * C(1:lastc,lastv)
+*
+ CALL CSCAL( LASTC, ONE - TAU, C( 1, LASTV ), 1 )
+ ELSE
+*
+* w(1:lastc,1) := C(1:lastc,firstv:lastv-1) * v(firstv:lastv-1,1)
+*
+ CALL CGEMV( 'No transpose', LASTC, LASTV - FIRSTV, ONE,
+ $ C( 1, FIRSTV ), LDC, V( I ), INCV, ZERO,
+ $ WORK, 1 )
+*
+* w(1:lastc,1) += C(1:lastc,lastv) * v(lastv,1)
+*
+ CALL CAXPY( LASTC, ONE, C( 1, LASTV ), 1, WORK, 1 )
+*
+* C(1:lastc,lastv) += - tau * v(lastv,1) * w(1:lastc,1)
+*
+ CALL CAXPY( LASTC, -TAU, WORK, 1, C( 1, LASTV ), 1 )
+*
+* C(1:lastc,firstv:lastv-1) += - tau * w(1:lastc,1) * v(firstv:lastv-1)**H
+*
+ CALL CGERC( LASTC, LASTV - FIRSTV, -TAU, WORK, 1, V( I ),
+ $ INCV, C( 1, FIRSTV ), LDC )
+ END IF
+ END IF
+ RETURN
+*
+* End of CLARF1L
+*
+ END
diff --git a/lapack-netlib/SRC/cunbdb.f b/lapack-netlib/SRC/cunbdb.f
index b45dcfde6f..ee0cb2871e 100644
--- a/lapack-netlib/SRC/cunbdb.f
+++ b/lapack-netlib/SRC/cunbdb.f
@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
-*> \htmlonly
*> Download CUNBDB + dependencies
*>
*> [TGZ]
@@ -13,7 +12,6 @@
*> [ZIP]
*>
*> [TXT]
-*> \endhtmlonly
*
* Definition:
* ===========
@@ -281,9 +279,11 @@
*> Algorithms, 50(1):33-65, 2009.
*>
* =====================================================================
- SUBROUTINE CUNBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12,
+ SUBROUTINE CUNBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12,
+ $ LDX12,
$ X21, LDX21, X22, LDX22, THETA, PHI, TAUP1,
$ TAUP2, TAUQ1, TAUQ2, WORK, LWORK, INFO )
+ IMPLICIT NONE
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
@@ -306,8 +306,6 @@ SUBROUTINE CUNBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12,
* .. Parameters ..
REAL REALONE
PARAMETER ( REALONE = 1.0E0 )
- COMPLEX ONE
- PARAMETER ( ONE = (1.0E0,0.0E0) )
* ..
* .. Local Scalars ..
LOGICAL COLMAJOR, LQUERY
@@ -315,7 +313,8 @@ SUBROUTINE CUNBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12,
REAL Z1, Z2, Z3, Z4
* ..
* .. External Subroutines ..
- EXTERNAL CAXPY, CLARF, CLARFGP, CSCAL, XERBLA
+ EXTERNAL CAXPY, CLARF1F, CLARFGP, CSCAL,
+ $ XERBLA
EXTERNAL CLACGV
*
* ..
@@ -418,11 +417,11 @@ SUBROUTINE CUNBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12,
$ SCNRM2( P-I+1, X11(I,I), 1 ) )
*
IF( P .GT. I ) THEN
- CALL CLARFGP( P-I+1, X11(I,I), X11(I+1,I), 1, TAUP1(I) )
+ CALL CLARFGP( P-I+1, X11(I,I), X11(I+1,I), 1,
+ $ TAUP1(I) )
ELSE IF ( P .EQ. I ) THEN
CALL CLARFGP( P-I+1, X11(I,I), X11(I,I), 1, TAUP1(I) )
END IF
- X11(I,I) = ONE
IF ( M-P .GT. I ) THEN
CALL CLARFGP( M-P-I+1, X21(I,I), X21(I+1,I), 1,
$ TAUP2(I) )
@@ -430,19 +429,20 @@ SUBROUTINE CUNBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12,
CALL CLARFGP( M-P-I+1, X21(I,I), X21(I,I), 1,
$ TAUP2(I) )
END IF
- X21(I,I) = ONE
*
IF ( Q .GT. I ) THEN
- CALL CLARF( 'L', P-I+1, Q-I, X11(I,I), 1,
- $ CONJG(TAUP1(I)), X11(I,I+1), LDX11, WORK )
- CALL CLARF( 'L', M-P-I+1, Q-I, X21(I,I), 1,
- $ CONJG(TAUP2(I)), X21(I,I+1), LDX21, WORK )
+ CALL CLARF1F( 'L', P-I+1, Q-I, X11(I,I), 1,
+ $ CONJG(TAUP1(I)), X11(I,I+1), LDX11,
+ $ WORK )
+ CALL CLARF1F( 'L', M-P-I+1, Q-I, X21(I,I), 1,
+ $ CONJG(TAUP2(I)), X21(I,I+1), LDX21,
+ $ WORK )
END IF
IF ( M-Q+1 .GT. I ) THEN
- CALL CLARF( 'L', P-I+1, M-Q-I+1, X11(I,I), 1,
- $ CONJG(TAUP1(I)), X12(I,I), LDX12, WORK )
- CALL CLARF( 'L', M-P-I+1, M-Q-I+1, X21(I,I), 1,
- $ CONJG(TAUP2(I)), X22(I,I), LDX22, WORK )
+ CALL CLARF1F( 'L', P-I+1, M-Q-I+1, X11(I,I), 1,
+ $ CONJG(TAUP1(I)), X12(I,I), LDX12, WORK )
+ CALL CLARF1F( 'L', M-P-I+1, M-Q-I+1, X21(I,I), 1,
+ $ CONJG(TAUP2(I)), X22(I,I), LDX22, WORK )
END IF
*
IF( I .LT. Q ) THEN
@@ -451,7 +451,8 @@ SUBROUTINE CUNBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12,
CALL CAXPY( Q-I, CMPLX( Z2*Z3*COS(THETA(I)), 0.0E0 ),
$ X21(I,I+1), LDX21, X11(I,I+1), LDX11 )
END IF
- CALL CSCAL( M-Q-I+1, CMPLX( -Z1*Z4*SIN(THETA(I)), 0.0E0 ),
+ CALL CSCAL( M-Q-I+1, CMPLX( -Z1*Z4*SIN(THETA(I)),
+ $ 0.0E0 ),
$ X12(I,I), LDX12 )
CALL CAXPY( M-Q-I+1, CMPLX( Z2*Z4*COS(THETA(I)), 0.0E0 ),
$ X22(I,I), LDX22, X12(I,I), LDX12 )
@@ -469,7 +470,6 @@ SUBROUTINE CUNBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12,
CALL CLARFGP( Q-I, X11(I,I+1), X11(I,I+2), LDX11,
$ TAUQ1(I) )
END IF
- X11(I,I+1) = ONE
END IF
IF ( M-Q+1 .GT. I ) THEN
CALL CLACGV( M-Q-I+1, X12(I,I), LDX12 )
@@ -481,21 +481,20 @@ SUBROUTINE CUNBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12,
$ TAUQ2(I) )
END IF
END IF
- X12(I,I) = ONE
*
IF( I .LT. Q ) THEN
- CALL CLARF( 'R', P-I, Q-I, X11(I,I+1), LDX11, TAUQ1(I),
- $ X11(I+1,I+1), LDX11, WORK )
- CALL CLARF( 'R', M-P-I, Q-I, X11(I,I+1), LDX11, TAUQ1(I),
- $ X21(I+1,I+1), LDX21, WORK )
+ CALL CLARF1F( 'R', P-I, Q-I, X11(I,I+1), LDX11,
+ $ TAUQ1(I), X11(I+1,I+1), LDX11, WORK )
+ CALL CLARF1F( 'R', M-P-I, Q-I, X11(I,I+1), LDX11,
+ $ TAUQ1(I), X21(I+1,I+1), LDX21, WORK )
END IF
IF ( P .GT. I ) THEN
- CALL CLARF( 'R', P-I, M-Q-I+1, X12(I,I), LDX12, TAUQ2(I),
- $ X12(I+1,I), LDX12, WORK )
+ CALL CLARF1F( 'R', P-I, M-Q-I+1, X12(I,I), LDX12,
+ $ TAUQ2(I), X12(I+1,I), LDX12, WORK )
END IF
IF ( M-P .GT. I ) THEN
- CALL CLARF( 'R', M-P-I, M-Q-I+1, X12(I,I), LDX12,
- $ TAUQ2(I), X22(I+1,I), LDX22, WORK )
+ CALL CLARF1F( 'R', M-P-I, M-Q-I+1, X12(I,I), LDX12,
+ $ TAUQ2(I), X22(I+1,I), LDX22, WORK )
END IF
*
IF( I .LT. Q )
@@ -518,15 +517,14 @@ SUBROUTINE CUNBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12,
CALL CLARFGP( M-Q-I+1, X12(I,I), X12(I,I+1), LDX12,
$ TAUQ2(I) )
END IF
- X12(I,I) = ONE
*
IF ( P .GT. I ) THEN
- CALL CLARF( 'R', P-I, M-Q-I+1, X12(I,I), LDX12, TAUQ2(I),
- $ X12(I+1,I), LDX12, WORK )
+ CALL CLARF1F( 'R', P-I, M-Q-I+1, X12(I,I), LDX12,
+ $ TAUQ2(I), X12(I+1,I), LDX12, WORK )
END IF
IF( M-P-Q .GE. 1 )
- $ CALL CLARF( 'R', M-P-Q, M-Q-I+1, X12(I,I), LDX12,
- $ TAUQ2(I), X22(Q+1,I), LDX22, WORK )
+ $ CALL CLARF1F( 'R', M-P-Q, M-Q-I+1, X12(I,I), LDX12,
+ $ TAUQ2(I), X22(Q+1,I), LDX22, WORK )
*
CALL CLACGV( M-Q-I+1, X12(I,I), LDX12 )
*
@@ -541,9 +539,9 @@ SUBROUTINE CUNBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12,
CALL CLACGV( M-P-Q-I+1, X22(Q+I,P+I), LDX22 )
CALL CLARFGP( M-P-Q-I+1, X22(Q+I,P+I), X22(Q+I,P+I+1),
$ LDX22, TAUQ2(P+I) )
- X22(Q+I,P+I) = ONE
- CALL CLARF( 'R', M-P-Q-I, M-P-Q-I+1, X22(Q+I,P+I), LDX22,
- $ TAUQ2(P+I), X22(Q+I+1,P+I), LDX22, WORK )
+ CALL CLARF1F( 'R', M-P-Q-I, M-P-Q-I+1, X22(Q+I,P+I),
+ $ LDX22, TAUQ2(P+I), X22(Q+I+1,P+I), LDX22,
+ $ WORK )
*
CALL CLACGV( M-P-Q-I+1, X22(Q+I,P+I), LDX22 )
*
@@ -580,8 +578,8 @@ SUBROUTINE CUNBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12,
CALL CLACGV( P-I+1, X11(I,I), LDX11 )
CALL CLACGV( M-P-I+1, X21(I,I), LDX21 )
*
- CALL CLARFGP( P-I+1, X11(I,I), X11(I,I+1), LDX11, TAUP1(I) )
- X11(I,I) = ONE
+ CALL CLARFGP( P-I+1, X11(I,I), X11(I,I+1), LDX11,
+ $ TAUP1(I) )
IF ( I .EQ. M-P ) THEN
CALL CLARFGP( M-P-I+1, X21(I,I), X21(I,I), LDX21,
$ TAUP2(I) )
@@ -589,16 +587,15 @@ SUBROUTINE CUNBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12,
CALL CLARFGP( M-P-I+1, X21(I,I), X21(I,I+1), LDX21,
$ TAUP2(I) )
END IF
- X21(I,I) = ONE
*
- CALL CLARF( 'R', Q-I, P-I+1, X11(I,I), LDX11, TAUP1(I),
- $ X11(I+1,I), LDX11, WORK )
- CALL CLARF( 'R', M-Q-I+1, P-I+1, X11(I,I), LDX11, TAUP1(I),
- $ X12(I,I), LDX12, WORK )
- CALL CLARF( 'R', Q-I, M-P-I+1, X21(I,I), LDX21, TAUP2(I),
- $ X21(I+1,I), LDX21, WORK )
- CALL CLARF( 'R', M-Q-I+1, M-P-I+1, X21(I,I), LDX21,
- $ TAUP2(I), X22(I,I), LDX22, WORK )
+ CALL CLARF1F( 'R', Q-I, P-I+1, X11(I,I), LDX11, TAUP1(I),
+ $ X11(I+1,I), LDX11, WORK )
+ CALL CLARF1F( 'R', M-Q-I+1, P-I+1, X11(I,I), LDX11,
+ $ TAUP1(I), X12(I,I), LDX12, WORK )
+ CALL CLARF1F( 'R', Q-I, M-P-I+1, X21(I,I), LDX21,
+ $ TAUP2(I), X21(I+1,I), LDX21, WORK )
+ CALL CLARF1F( 'R', M-Q-I+1, M-P-I+1, X21(I,I), LDX21,
+ $ TAUP2(I), X22(I,I), LDX22, WORK )
*
CALL CLACGV( P-I+1, X11(I,I), LDX11 )
CALL CLACGV( M-P-I+1, X21(I,I), LDX21 )
@@ -609,7 +606,8 @@ SUBROUTINE CUNBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12,
CALL CAXPY( Q-I, CMPLX( Z2*Z3*COS(THETA(I)), 0.0E0 ),
$ X21(I+1,I), 1, X11(I+1,I), 1 )
END IF
- CALL CSCAL( M-Q-I+1, CMPLX( -Z1*Z4*SIN(THETA(I)), 0.0E0 ),
+ CALL CSCAL( M-Q-I+1, CMPLX( -Z1*Z4*SIN(THETA(I)),
+ $ 0.0E0 ),
$ X12(I,I), 1 )
CALL CAXPY( M-Q-I+1, CMPLX( Z2*Z4*COS(THETA(I)), 0.0E0 ),
$ X22(I,I), 1, X12(I,I), 1 )
@@ -619,24 +617,27 @@ SUBROUTINE CUNBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12,
$ SCNRM2( M-Q-I+1, X12(I,I), 1 ) )
*
IF( I .LT. Q ) THEN
- CALL CLARFGP( Q-I, X11(I+1,I), X11(I+2,I), 1, TAUQ1(I) )
- X11(I+1,I) = ONE
+ CALL CLARFGP( Q-I, X11(I+1,I), X11(I+2,I), 1,
+ $ TAUQ1(I) )
END IF
- CALL CLARFGP( M-Q-I+1, X12(I,I), X12(I+1,I), 1, TAUQ2(I) )
- X12(I,I) = ONE
+ CALL CLARFGP( M-Q-I+1, X12(I,I), X12(I+1,I), 1,
+ $ TAUQ2(I) )
*
IF( I .LT. Q ) THEN
- CALL CLARF( 'L', Q-I, P-I, X11(I+1,I), 1,
- $ CONJG(TAUQ1(I)), X11(I+1,I+1), LDX11, WORK )
- CALL CLARF( 'L', Q-I, M-P-I, X11(I+1,I), 1,
- $ CONJG(TAUQ1(I)), X21(I+1,I+1), LDX21, WORK )
+ CALL CLARF1F( 'L', Q-I, P-I, X11(I+1,I), 1,
+ $ CONJG(TAUQ1(I)), X11(I+1,I+1), LDX11,
+ $ WORK )
+ CALL CLARF1F( 'L', Q-I, M-P-I, X11(I+1,I), 1,
+ $ CONJG(TAUQ1(I)), X21(I+1,I+1), LDX21,
+ $ WORK )
END IF
- CALL CLARF( 'L', M-Q-I+1, P-I, X12(I,I), 1, CONJG(TAUQ2(I)),
- $ X12(I,I+1), LDX12, WORK )
+ CALL CLARF1F( 'L', M-Q-I+1, P-I, X12(I,I), 1,
+ $ CONJG(TAUQ2(I)), X12(I,I+1), LDX12, WORK )
IF ( M-P .GT. I ) THEN
- CALL CLARF( 'L', M-Q-I+1, M-P-I, X12(I,I), 1,
- $ CONJG(TAUQ2(I)), X22(I,I+1), LDX22, WORK )
+ CALL CLARF1F( 'L', M-Q-I+1, M-P-I, X12(I,I), 1,
+ $ CONJG(TAUQ2(I)), X22(I,I+1), LDX22,
+ $ WORK )
END IF
END DO
*
@@ -644,17 +645,20 @@ SUBROUTINE CUNBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12,
*
DO I = Q + 1, P
*
- CALL CSCAL( M-Q-I+1, CMPLX( -Z1*Z4, 0.0E0 ), X12(I,I), 1 )
- CALL CLARFGP( M-Q-I+1, X12(I,I), X12(I+1,I), 1, TAUQ2(I) )
- X12(I,I) = ONE
+ CALL CSCAL( M-Q-I+1, CMPLX( -Z1*Z4, 0.0E0 ), X12(I,I),
+ $ 1 )
+ CALL CLARFGP( M-Q-I+1, X12(I,I), X12(I+1,I), 1,
+ $ TAUQ2(I) )
*
IF ( P .GT. I ) THEN
- CALL CLARF( 'L', M-Q-I+1, P-I, X12(I,I), 1,
- $ CONJG(TAUQ2(I)), X12(I,I+1), LDX12, WORK )
+ CALL CLARF1F( 'L', M-Q-I+1, P-I, X12(I,I), 1,
+ $ CONJG(TAUQ2(I)), X12(I,I+1), LDX12,
+ $ WORK )
END IF
IF( M-P-Q .GE. 1 )
- $ CALL CLARF( 'L', M-Q-I+1, M-P-Q, X12(I,I), 1,
- $ CONJG(TAUQ2(I)), X22(I,Q+1), LDX22, WORK )
+ $ CALL CLARF1F( 'L', M-Q-I+1, M-P-Q, X12(I,I), 1,
+ $ CONJG(TAUQ2(I)), X22(I,Q+1), LDX22,
+ $ WORK )
*
END DO
*
@@ -666,11 +670,10 @@ SUBROUTINE CUNBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12,
$ X22(P+I,Q+I), 1 )
CALL CLARFGP( M-P-Q-I+1, X22(P+I,Q+I), X22(P+I+1,Q+I), 1,
$ TAUQ2(P+I) )
- X22(P+I,Q+I) = ONE
IF ( M-P-Q .NE. I ) THEN
- CALL CLARF( 'L', M-P-Q-I+1, M-P-Q-I, X22(P+I,Q+I), 1,
- $ CONJG(TAUQ2(P+I)), X22(P+I,Q+I+1), LDX22,
- $ WORK )
+ CALL CLARF1F( 'L', M-P-Q-I+1, M-P-Q-I, X22(P+I,Q+I),
+ $ 1, CONJG(TAUQ2(P+I)), X22(P+I,Q+I+1),
+ $ LDX22, WORK )
END IF
END DO
*
diff --git a/lapack-netlib/SRC/cunbdb1.f b/lapack-netlib/SRC/cunbdb1.f
index a4875ab5ba..08b2fd8465 100644
--- a/lapack-netlib/SRC/cunbdb1.f
+++ b/lapack-netlib/SRC/cunbdb1.f
@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
-*> \htmlonly
*> Download CUNBDB1 + dependencies
*>
*> [TGZ]
@@ -13,7 +12,6 @@
*> [ZIP]
*>
*> [TXT]
-*> \endhtmlonly
*
* Definition:
* ===========
@@ -197,8 +195,10 @@
*> Algorithms, 50(1):33-65, 2009.
*>
* =====================================================================
- SUBROUTINE CUNBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
+ SUBROUTINE CUNBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA,
+ $ PHI,
$ TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO )
+ IMPLICIT NONE
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
@@ -215,10 +215,6 @@ SUBROUTINE CUNBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
*
* ====================================================================
*
-* .. Parameters ..
- COMPLEX ONE
- PARAMETER ( ONE = (1.0E0,0.0E0) )
-* ..
* .. Local Scalars ..
REAL C, S
INTEGER CHILDINFO, I, ILARF, IORBDB5, LLARF, LORBDB5,
@@ -226,7 +222,8 @@ SUBROUTINE CUNBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
LOGICAL LQUERY
* ..
* .. External Subroutines ..
- EXTERNAL CLARF, CLARFGP, CUNBDB5, CSROT, XERBLA
+ EXTERNAL CLARF1F, CLARFGP, CUNBDB5, CSROT,
+ $ XERBLA
EXTERNAL CLACGV
* ..
* .. External Functions ..
@@ -285,24 +282,24 @@ SUBROUTINE CUNBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
THETA(I) = ATAN2( REAL( X21(I,I) ), REAL( X11(I,I) ) )
C = COS( THETA(I) )
S = SIN( THETA(I) )
- X11(I,I) = ONE
- X21(I,I) = ONE
- CALL CLARF( 'L', P-I+1, Q-I, X11(I,I), 1, CONJG(TAUP1(I)),
- $ X11(I,I+1), LDX11, WORK(ILARF) )
- CALL CLARF( 'L', M-P-I+1, Q-I, X21(I,I), 1, CONJG(TAUP2(I)),
- $ X21(I,I+1), LDX21, WORK(ILARF) )
+ CALL CLARF1F( 'L', P-I+1, Q-I, X11(I,I), 1, CONJG(TAUP1(I)),
+ $ X11(I,I+1), LDX11, WORK(ILARF) )
+ CALL CLARF1F( 'L', M-P-I+1, Q-I, X21(I,I), 1,
+ $ CONJG(TAUP2(I)), X21(I,I+1), LDX21,
+ $ WORK(ILARF) )
*
IF( I .LT. Q ) THEN
CALL CSROT( Q-I, X11(I,I+1), LDX11, X21(I,I+1), LDX21, C,
$ S )
CALL CLACGV( Q-I, X21(I,I+1), LDX21 )
- CALL CLARFGP( Q-I, X21(I,I+1), X21(I,I+2), LDX21, TAUQ1(I) )
+ CALL CLARFGP( Q-I, X21(I,I+1), X21(I,I+2), LDX21,
+ $ TAUQ1(I) )
S = REAL( X21(I,I+1) )
- X21(I,I+1) = ONE
- CALL CLARF( 'R', P-I, Q-I, X21(I,I+1), LDX21, TAUQ1(I),
- $ X11(I+1,I+1), LDX11, WORK(ILARF) )
- CALL CLARF( 'R', M-P-I, Q-I, X21(I,I+1), LDX21, TAUQ1(I),
- $ X21(I+1,I+1), LDX21, WORK(ILARF) )
+ CALL CLARF1F( 'R', P-I, Q-I, X21(I,I+1), LDX21, TAUQ1(I),
+ $ X11(I+1,I+1), LDX11, WORK(ILARF) )
+ CALL CLARF1F( 'R', M-P-I, Q-I, X21(I,I+1), LDX21,
+ $ TAUQ1(I), X21(I+1,I+1), LDX21,
+ $ WORK(ILARF) )
CALL CLACGV( Q-I, X21(I,I+1), LDX21 )
C = SQRT( SCNRM2( P-I, X11(I+1,I+1), 1 )**2
$ + SCNRM2( M-P-I, X21(I+1,I+1), 1 )**2 )
diff --git a/lapack-netlib/SRC/cunbdb2.f b/lapack-netlib/SRC/cunbdb2.f
index 6399964f8d..337e572a0d 100644
--- a/lapack-netlib/SRC/cunbdb2.f
+++ b/lapack-netlib/SRC/cunbdb2.f
@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
-*> \htmlonly
*> Download CUNBDB2 + dependencies
*>
*> [TGZ]
@@ -13,7 +12,6 @@
*> [ZIP]
*>
*> [TXT]
-*> \endhtmlonly
*
* Definition:
* ===========
@@ -197,8 +195,10 @@
*> Algorithms, 50(1):33-65, 2009.
*>
* =====================================================================
- SUBROUTINE CUNBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
+ SUBROUTINE CUNBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA,
+ $ PHI,
$ TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO )
+ IMPLICIT NONE
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
@@ -216,9 +216,8 @@ SUBROUTINE CUNBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
* ====================================================================
*
* .. Parameters ..
- COMPLEX NEGONE, ONE
- PARAMETER ( NEGONE = (-1.0E0,0.0E0),
- $ ONE = (1.0E0,0.0E0) )
+ COMPLEX NEGONE
+ PARAMETER ( NEGONE = (-1.0E0,0.0E0) )
* ..
* .. Local Scalars ..
REAL C, S
@@ -227,7 +226,8 @@ SUBROUTINE CUNBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
LOGICAL LQUERY
* ..
* .. External Subroutines ..
- EXTERNAL CLARF, CLARFGP, CUNBDB5, CSROT, CSCAL, CLACGV,
+ EXTERNAL CLARF1F, CLARFGP, CUNBDB5, CSROT, CSCAL,
+ $ CLACGV,
$ XERBLA
* ..
* .. External Functions ..
@@ -288,11 +288,10 @@ SUBROUTINE CUNBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
CALL CLACGV( Q-I+1, X11(I,I), LDX11 )
CALL CLARFGP( Q-I+1, X11(I,I), X11(I,I+1), LDX11, TAUQ1(I) )
C = REAL( X11(I,I) )
- X11(I,I) = ONE
- CALL CLARF( 'R', P-I, Q-I+1, X11(I,I), LDX11, TAUQ1(I),
- $ X11(I+1,I), LDX11, WORK(ILARF) )
- CALL CLARF( 'R', M-P-I+1, Q-I+1, X11(I,I), LDX11, TAUQ1(I),
- $ X21(I,I), LDX21, WORK(ILARF) )
+ CALL CLARF1F( 'R', P-I, Q-I+1, X11(I,I), LDX11, TAUQ1(I),
+ $ X11(I+1,I), LDX11, WORK(ILARF) )
+ CALL CLARF1F( 'R', M-P-I+1, Q-I+1, X11(I,I), LDX11,
+ $ TAUQ1(I), X21(I,I), LDX21, WORK(ILARF) )
CALL CLACGV( Q-I+1, X11(I,I), LDX11 )
S = SQRT( SCNRM2( P-I, X11(I+1,I), 1 )**2
$ + SCNRM2( M-P-I+1, X21(I,I), 1 )**2 )
@@ -308,13 +307,13 @@ SUBROUTINE CUNBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
PHI(I) = ATAN2( REAL( X11(I+1,I) ), REAL( X21(I,I) ) )
C = COS( PHI(I) )
S = SIN( PHI(I) )
- X11(I+1,I) = ONE
- CALL CLARF( 'L', P-I, Q-I, X11(I+1,I), 1, CONJG(TAUP1(I)),
- $ X11(I+1,I+1), LDX11, WORK(ILARF) )
+ CALL CLARF1F( 'L', P-I, Q-I, X11(I+1,I), 1,
+ $ CONJG(TAUP1(I)), X11(I+1,I+1), LDX11,
+ $ WORK(ILARF) )
END IF
- X21(I,I) = ONE
- CALL CLARF( 'L', M-P-I+1, Q-I, X21(I,I), 1, CONJG(TAUP2(I)),
- $ X21(I,I+1), LDX21, WORK(ILARF) )
+ CALL CLARF1F( 'L', M-P-I+1, Q-I, X21(I,I), 1,
+ $ CONJG(TAUP2(I)), X21(I,I+1), LDX21,
+ $ WORK(ILARF) )
*
END DO
*
@@ -322,9 +321,9 @@ SUBROUTINE CUNBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
*
DO I = P + 1, Q
CALL CLARFGP( M-P-I+1, X21(I,I), X21(I+1,I), 1, TAUP2(I) )
- X21(I,I) = ONE
- CALL CLARF( 'L', M-P-I+1, Q-I, X21(I,I), 1, CONJG(TAUP2(I)),
- $ X21(I,I+1), LDX21, WORK(ILARF) )
+ CALL CLARF1F( 'L', M-P-I+1, Q-I, X21(I,I), 1,
+ $ CONJG(TAUP2(I)), X21(I,I+1), LDX21,
+ $ WORK(ILARF) )
END DO
*
RETURN
diff --git a/lapack-netlib/SRC/cunbdb3.f b/lapack-netlib/SRC/cunbdb3.f
index d024605979..c03de68257 100644
--- a/lapack-netlib/SRC/cunbdb3.f
+++ b/lapack-netlib/SRC/cunbdb3.f
@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
-*> \htmlonly
*> Download CUNBDB3 + dependencies
*>
*> [TGZ]
@@ -13,7 +12,6 @@
*> [ZIP]
*>
*> [TXT]
-*> \endhtmlonly
*
* Definition:
* ===========
@@ -197,8 +195,10 @@
*> Algorithms, 50(1):33-65, 2009.
*>
* =====================================================================
- SUBROUTINE CUNBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
+ SUBROUTINE CUNBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA,
+ $ PHI,
$ TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO )
+ IMPLICIT NONE
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
@@ -215,10 +215,6 @@ SUBROUTINE CUNBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
*
* ====================================================================
*
-* .. Parameters ..
- COMPLEX ONE
- PARAMETER ( ONE = (1.0E0,0.0E0) )
-* ..
* .. Local Scalars ..
REAL C, S
INTEGER CHILDINFO, I, ILARF, IORBDB5, LLARF, LORBDB5,
@@ -226,7 +222,8 @@ SUBROUTINE CUNBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
LOGICAL LQUERY
* ..
* .. External Subroutines ..
- EXTERNAL CLARF, CLARFGP, CUNBDB5, CSROT, CLACGV, XERBLA
+ EXTERNAL CLARF1F, CLARFGP, CUNBDB5, CSROT, CLACGV,
+ $ XERBLA
* ..
* .. External Functions ..
REAL SCNRM2, SROUNDUP_LWORK
@@ -287,11 +284,10 @@ SUBROUTINE CUNBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
CALL CLACGV( Q-I+1, X21(I,I), LDX21 )
CALL CLARFGP( Q-I+1, X21(I,I), X21(I,I+1), LDX21, TAUQ1(I) )
S = REAL( X21(I,I) )
- X21(I,I) = ONE
- CALL CLARF( 'R', P-I+1, Q-I+1, X21(I,I), LDX21, TAUQ1(I),
- $ X11(I,I), LDX11, WORK(ILARF) )
- CALL CLARF( 'R', M-P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I),
- $ X21(I+1,I), LDX21, WORK(ILARF) )
+ CALL CLARF1F( 'R', P-I+1, Q-I+1, X21(I,I), LDX21, TAUQ1(I),
+ $ X11(I,I), LDX11, WORK(ILARF) )
+ CALL CLARF1F( 'R', M-P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I),
+ $ X21(I+1,I), LDX21, WORK(ILARF) )
CALL CLACGV( Q-I+1, X21(I,I), LDX21 )
C = SQRT( SCNRM2( P-I+1, X11(I,I), 1 )**2
$ + SCNRM2( M-P-I, X21(I+1,I), 1 )**2 )
@@ -302,17 +298,17 @@ SUBROUTINE CUNBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
$ WORK(IORBDB5), LORBDB5, CHILDINFO )
CALL CLARFGP( P-I+1, X11(I,I), X11(I+1,I), 1, TAUP1(I) )
IF( I .LT. M-P ) THEN
- CALL CLARFGP( M-P-I, X21(I+1,I), X21(I+2,I), 1, TAUP2(I) )
+ CALL CLARFGP( M-P-I, X21(I+1,I), X21(I+2,I), 1,
+ $ TAUP2(I) )
PHI(I) = ATAN2( REAL( X21(I+1,I) ), REAL( X11(I,I) ) )
C = COS( PHI(I) )
S = SIN( PHI(I) )
- X21(I+1,I) = ONE
- CALL CLARF( 'L', M-P-I, Q-I, X21(I+1,I), 1, CONJG(TAUP2(I)),
- $ X21(I+1,I+1), LDX21, WORK(ILARF) )
+ CALL CLARF1F( 'L', M-P-I, Q-I, X21(I+1,I), 1,
+ $ CONJG(TAUP2(I)), X21(I+1,I+1), LDX21,
+ $ WORK(ILARF) )
END IF
- X11(I,I) = ONE
- CALL CLARF( 'L', P-I+1, Q-I, X11(I,I), 1, CONJG(TAUP1(I)),
- $ X11(I,I+1), LDX11, WORK(ILARF) )
+ CALL CLARF1F( 'L', P-I+1, Q-I, X11(I,I), 1, CONJG(TAUP1(I)),
+ $ X11(I,I+1), LDX11, WORK(ILARF) )
*
END DO
*
@@ -320,9 +316,8 @@ SUBROUTINE CUNBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
*
DO I = M-P + 1, Q
CALL CLARFGP( P-I+1, X11(I,I), X11(I+1,I), 1, TAUP1(I) )
- X11(I,I) = ONE
- CALL CLARF( 'L', P-I+1, Q-I, X11(I,I), 1, CONJG(TAUP1(I)),
- $ X11(I,I+1), LDX11, WORK(ILARF) )
+ CALL CLARF1F( 'L', P-I+1, Q-I, X11(I,I), 1, CONJG(TAUP1(I)),
+ $ X11(I,I+1), LDX11, WORK(ILARF) )
END DO
*
RETURN
diff --git a/lapack-netlib/SRC/cunbdb4.f b/lapack-netlib/SRC/cunbdb4.f
index 33acc1ee51..16e71860c1 100644
--- a/lapack-netlib/SRC/cunbdb4.f
+++ b/lapack-netlib/SRC/cunbdb4.f
@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
-*> \htmlonly
*> Download CUNBDB4 + dependencies
*>
*> [TGZ]
@@ -13,7 +12,6 @@
*> [ZIP]
*>
*> [TXT]
-*> \endhtmlonly
*
* Definition:
* ===========
@@ -207,9 +205,11 @@
*> Algorithms, 50(1):33-65, 2009.
*>
* =====================================================================
- SUBROUTINE CUNBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
+ SUBROUTINE CUNBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA,
+ $ PHI,
$ TAUP1, TAUP2, TAUQ1, PHANTOM, WORK, LWORK,
$ INFO )
+ IMPLICIT NONE
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
@@ -227,8 +227,8 @@ SUBROUTINE CUNBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
* ====================================================================
*
* .. Parameters ..
- COMPLEX NEGONE, ONE, ZERO
- PARAMETER ( NEGONE = (-1.0E0,0.0E0), ONE = (1.0E0,0.0E0),
+ COMPLEX NEGONE, ZERO
+ PARAMETER ( NEGONE = (-1.0E0,0.0E0),
$ ZERO = (0.0E0,0.0E0) )
* ..
* .. Local Scalars ..
@@ -238,7 +238,8 @@ SUBROUTINE CUNBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
LOGICAL LQUERY
* ..
* .. External Subroutines ..
- EXTERNAL CLARF, CLARFGP, CUNBDB5, CSROT, CSCAL, CLACGV,
+ EXTERNAL CLARF1F, CLARFGP, CUNBDB5, CSROT, CSCAL,
+ $ CLACGV,
$ XERBLA
* ..
* .. External Functions ..
@@ -302,44 +303,43 @@ SUBROUTINE CUNBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
$ LORBDB5, CHILDINFO )
CALL CSCAL( P, NEGONE, PHANTOM(1), 1 )
CALL CLARFGP( P, PHANTOM(1), PHANTOM(2), 1, TAUP1(1) )
- CALL CLARFGP( M-P, PHANTOM(P+1), PHANTOM(P+2), 1, TAUP2(1) )
+ CALL CLARFGP( M-P, PHANTOM(P+1), PHANTOM(P+2), 1,
+ $ TAUP2(1) )
THETA(I) = ATAN2( REAL( PHANTOM(1) ), REAL( PHANTOM(P+1) ) )
C = COS( THETA(I) )
S = SIN( THETA(I) )
- PHANTOM(1) = ONE
- PHANTOM(P+1) = ONE
- CALL CLARF( 'L', P, Q, PHANTOM(1), 1, CONJG(TAUP1(1)), X11,
- $ LDX11, WORK(ILARF) )
- CALL CLARF( 'L', M-P, Q, PHANTOM(P+1), 1, CONJG(TAUP2(1)),
- $ X21, LDX21, WORK(ILARF) )
+ CALL CLARF1F( 'L', P, Q, PHANTOM(1), 1, CONJG(TAUP1(1)),
+ $ X11, LDX11, WORK(ILARF) )
+ CALL CLARF1F( 'L', M-P, Q, PHANTOM(P+1), 1,
+ $ CONJG(TAUP2(1)), X21, LDX21, WORK(ILARF) )
ELSE
CALL CUNBDB5( P-I+1, M-P-I+1, Q-I+1, X11(I,I-1), 1,
$ X21(I,I-1), 1, X11(I,I), LDX11, X21(I,I),
$ LDX21, WORK(IORBDB5), LORBDB5, CHILDINFO )
CALL CSCAL( P-I+1, NEGONE, X11(I,I-1), 1 )
- CALL CLARFGP( P-I+1, X11(I,I-1), X11(I+1,I-1), 1, TAUP1(I) )
+ CALL CLARFGP( P-I+1, X11(I,I-1), X11(I+1,I-1), 1,
+ $ TAUP1(I) )
CALL CLARFGP( M-P-I+1, X21(I,I-1), X21(I+1,I-1), 1,
$ TAUP2(I) )
THETA(I) = ATAN2( REAL( X11(I,I-1) ), REAL( X21(I,I-1) ) )
C = COS( THETA(I) )
S = SIN( THETA(I) )
- X11(I,I-1) = ONE
- X21(I,I-1) = ONE
- CALL CLARF( 'L', P-I+1, Q-I+1, X11(I,I-1), 1,
- $ CONJG(TAUP1(I)), X11(I,I), LDX11, WORK(ILARF) )
- CALL CLARF( 'L', M-P-I+1, Q-I+1, X21(I,I-1), 1,
- $ CONJG(TAUP2(I)), X21(I,I), LDX21, WORK(ILARF) )
+ CALL CLARF1F( 'L', P-I+1, Q-I+1, X11(I,I-1), 1,
+ $ CONJG(TAUP1(I)), X11(I,I), LDX11,
+ $ WORK(ILARF) )
+ CALL CLARF1F( 'L', M-P-I+1, Q-I+1, X21(I,I-1), 1,
+ $ CONJG(TAUP2(I)), X21(I,I), LDX21,
+ $ WORK(ILARF) )
END IF
*
CALL CSROT( Q-I+1, X11(I,I), LDX11, X21(I,I), LDX21, S, -C )
CALL CLACGV( Q-I+1, X21(I,I), LDX21 )
CALL CLARFGP( Q-I+1, X21(I,I), X21(I,I+1), LDX21, TAUQ1(I) )
C = REAL( X21(I,I) )
- X21(I,I) = ONE
- CALL CLARF( 'R', P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I),
- $ X11(I+1,I), LDX11, WORK(ILARF) )
- CALL CLARF( 'R', M-P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I),
- $ X21(I+1,I), LDX21, WORK(ILARF) )
+ CALL CLARF1F( 'R', P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I),
+ $ X11(I+1,I), LDX11, WORK(ILARF) )
+ CALL CLARF1F( 'R', M-P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I),
+ $ X21(I+1,I), LDX21, WORK(ILARF) )
CALL CLACGV( Q-I+1, X21(I,I), LDX21 )
IF( I .LT. M-Q ) THEN
S = SQRT( SCNRM2( P-I, X11(I+1,I), 1 )**2
@@ -354,11 +354,10 @@ SUBROUTINE CUNBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
DO I = M - Q + 1, P
CALL CLACGV( Q-I+1, X11(I,I), LDX11 )
CALL CLARFGP( Q-I+1, X11(I,I), X11(I,I+1), LDX11, TAUQ1(I) )
- X11(I,I) = ONE
- CALL CLARF( 'R', P-I, Q-I+1, X11(I,I), LDX11, TAUQ1(I),
- $ X11(I+1,I), LDX11, WORK(ILARF) )
- CALL CLARF( 'R', Q-P, Q-I+1, X11(I,I), LDX11, TAUQ1(I),
- $ X21(M-Q+1,I), LDX21, WORK(ILARF) )
+ CALL CLARF1F( 'R', P-I, Q-I+1, X11(I,I), LDX11, TAUQ1(I),
+ $ X11(I+1,I), LDX11, WORK(ILARF) )
+ CALL CLARF1F( 'R', Q-P, Q-I+1, X11(I,I), LDX11, TAUQ1(I),
+ $ X21(M-Q+1,I), LDX21, WORK(ILARF) )
CALL CLACGV( Q-I+1, X11(I,I), LDX11 )
END DO
*
@@ -366,11 +365,12 @@ SUBROUTINE CUNBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
*
DO I = P + 1, Q
CALL CLACGV( Q-I+1, X21(M-Q+I-P,I), LDX21 )
- CALL CLARFGP( Q-I+1, X21(M-Q+I-P,I), X21(M-Q+I-P,I+1), LDX21,
+ CALL CLARFGP( Q-I+1, X21(M-Q+I-P,I), X21(M-Q+I-P,I+1),
+ $ LDX21,
$ TAUQ1(I) )
- X21(M-Q+I-P,I) = ONE
- CALL CLARF( 'R', Q-I, Q-I+1, X21(M-Q+I-P,I), LDX21, TAUQ1(I),
- $ X21(M-Q+I-P+1,I), LDX21, WORK(ILARF) )
+ CALL CLARF1F( 'R', Q-I, Q-I+1, X21(M-Q+I-P,I), LDX21,
+ $ TAUQ1(I), X21(M-Q+I-P+1,I), LDX21,
+ $ WORK(ILARF) )
CALL CLACGV( Q-I+1, X21(M-Q+I-P,I), LDX21 )
END DO
*
diff --git a/lapack-netlib/SRC/cung2l.f b/lapack-netlib/SRC/cung2l.f
index a05843a5d3..477876cc5c 100644
--- a/lapack-netlib/SRC/cung2l.f
+++ b/lapack-netlib/SRC/cung2l.f
@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
-*> \htmlonly
*> Download CUNG2L + dependencies
*>
*> [TGZ]
@@ -13,7 +12,6 @@
*> [ZIP]
*>
*> [TXT]
-*> \endhtmlonly
*
* Definition:
* ===========
@@ -107,10 +105,11 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \ingroup complexOTHERcomputational
+*> \ingroup ung2l
*
* =====================================================================
SUBROUTINE CUNG2L( M, N, K, A, LDA, TAU, WORK, INFO )
+ IMPLICIT NONE
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
@@ -134,7 +133,7 @@ SUBROUTINE CUNG2L( M, N, K, A, LDA, TAU, WORK, INFO )
INTEGER I, II, J, L
* ..
* .. External Subroutines ..
- EXTERNAL CLARF, CSCAL, XERBLA
+ EXTERNAL CLARF1L, CSCAL, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
@@ -178,8 +177,8 @@ SUBROUTINE CUNG2L( M, N, K, A, LDA, TAU, WORK, INFO )
* Apply H(i) to A(1:m-k+i,1:n-k+i) from the left
*
A( M-N+II, II ) = ONE
- CALL CLARF( 'Left', M-N+II, II-1, A( 1, II ), 1, TAU( I ), A,
- $ LDA, WORK )
+ CALL CLARF1L( 'Left', M-N+II, II-1, A( 1, II ), 1, TAU( I ),
+ $ A, LDA, WORK )
CALL CSCAL( M-N+II-1, -TAU( I ), A( 1, II ), 1 )
A( M-N+II, II ) = ONE - TAU( I )
*
diff --git a/lapack-netlib/SRC/cung2r.f b/lapack-netlib/SRC/cung2r.f
index a984818c1e..d48e050aa9 100644
--- a/lapack-netlib/SRC/cung2r.f
+++ b/lapack-netlib/SRC/cung2r.f
@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
-*> \htmlonly
*> Download CUNG2R + dependencies
*>
*> [TGZ]
@@ -13,7 +12,6 @@
*> [ZIP]
*>
*> [TXT]
-*> \endhtmlonly
*
* Definition:
* ===========
@@ -107,10 +105,11 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \ingroup complexOTHERcomputational
+*> \ingroup ung2r
*
* =====================================================================
SUBROUTINE CUNG2R( M, N, K, A, LDA, TAU, WORK, INFO )
+ IMPLICIT NONE
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
@@ -134,7 +133,7 @@ SUBROUTINE CUNG2R( M, N, K, A, LDA, TAU, WORK, INFO )
INTEGER I, J, L
* ..
* .. External Subroutines ..
- EXTERNAL CLARF, CSCAL, XERBLA
+ EXTERNAL CLARF1F, CSCAL, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
@@ -177,9 +176,8 @@ SUBROUTINE CUNG2R( M, N, K, A, LDA, TAU, WORK, INFO )
* Apply H(i) to A(i:m,i:n) from the left
*
IF( I.LT.N ) THEN
- A( I, I ) = ONE
- CALL CLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ),
- $ A( I, I+1 ), LDA, WORK )
+ CALL CLARF1F( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ),
+ $ A( I, I+1 ), LDA, WORK )
END IF
IF( I.LT.M )
$ CALL CSCAL( M-I, -TAU( I ), A( I+1, I ), 1 )
diff --git a/lapack-netlib/SRC/cungl2.f b/lapack-netlib/SRC/cungl2.f
index 81a3b89cd8..8b5b2b8457 100644
--- a/lapack-netlib/SRC/cungl2.f
+++ b/lapack-netlib/SRC/cungl2.f
@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
-*> \htmlonly
*> Download CUNGL2 + dependencies
*>
*> [TGZ]
@@ -13,7 +12,6 @@
*> [ZIP]
*>
*> [TXT]
-*> \endhtmlonly
*
* Definition:
* ===========
@@ -106,10 +104,11 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \ingroup complexOTHERcomputational
+*> \ingroup ungl2
*
* =====================================================================
SUBROUTINE CUNGL2( M, N, K, A, LDA, TAU, WORK, INFO )
+ IMPLICIT NONE
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
@@ -133,7 +132,7 @@ SUBROUTINE CUNGL2( M, N, K, A, LDA, TAU, WORK, INFO )
INTEGER I, J, L
* ..
* .. External Subroutines ..
- EXTERNAL CLACGV, CLARF, CSCAL, XERBLA
+ EXTERNAL CLACGV, CLARF1F, CSCAL, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC CONJG, MAX
@@ -182,9 +181,9 @@ SUBROUTINE CUNGL2( M, N, K, A, LDA, TAU, WORK, INFO )
IF( I.LT.N ) THEN
CALL CLACGV( N-I, A( I, I+1 ), LDA )
IF( I.LT.M ) THEN
- A( I, I ) = ONE
- CALL CLARF( 'Right', M-I, N-I+1, A( I, I ), LDA,
- $ CONJG( TAU( I ) ), A( I+1, I ), LDA, WORK )
+ CALL CLARF1F( 'Right', M-I, N-I+1, A( I, I ), LDA,
+ $ CONJG( TAU( I ) ), A( I+1, I ), LDA,
+ $ WORK )
END IF
CALL CSCAL( N-I, -TAU( I ), A( I, I+1 ), LDA )
CALL CLACGV( N-I, A( I, I+1 ), LDA )
diff --git a/lapack-netlib/SRC/cungr2.f b/lapack-netlib/SRC/cungr2.f
index 1f2f2b4610..e421117f02 100644
--- a/lapack-netlib/SRC/cungr2.f
+++ b/lapack-netlib/SRC/cungr2.f
@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
-*> \htmlonly
*> Download CUNGR2 + dependencies
*>
*> [TGZ]
@@ -13,7 +12,6 @@
*> [ZIP]
*>
*> [TXT]
-*> \endhtmlonly
*
* Definition:
* ===========
@@ -107,10 +105,11 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \ingroup complexOTHERcomputational
+*> \ingroup ungr2
*
* =====================================================================
SUBROUTINE CUNGR2( M, N, K, A, LDA, TAU, WORK, INFO )
+ IMPLICIT NONE
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
@@ -134,7 +133,7 @@ SUBROUTINE CUNGR2( M, N, K, A, LDA, TAU, WORK, INFO )
INTEGER I, II, J, L
* ..
* .. External Subroutines ..
- EXTERNAL CLACGV, CLARF, CSCAL, XERBLA
+ EXTERNAL CLACGV, CLARF1L, CSCAL, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC CONJG, MAX
@@ -183,8 +182,8 @@ SUBROUTINE CUNGR2( M, N, K, A, LDA, TAU, WORK, INFO )
*
CALL CLACGV( N-M+II-1, A( II, 1 ), LDA )
A( II, N-M+II ) = ONE
- CALL CLARF( 'Right', II-1, N-M+II, A( II, 1 ), LDA,
- $ CONJG( TAU( I ) ), A, LDA, WORK )
+ CALL CLARF1L( 'Right', II-1, N-M+II, A( II, 1 ), LDA,
+ $ CONJG( TAU( I ) ), A, LDA, WORK )
CALL CSCAL( N-M+II-1, -TAU( I ), A( II, 1 ), LDA )
CALL CLACGV( N-M+II-1, A( II, 1 ), LDA )
A( II, N-M+II ) = ONE - CONJG( TAU( I ) )
diff --git a/lapack-netlib/SRC/cunm2l.f b/lapack-netlib/SRC/cunm2l.f
index 416c0a0c36..0b6ffc8ca0 100644
--- a/lapack-netlib/SRC/cunm2l.f
+++ b/lapack-netlib/SRC/cunm2l.f
@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
-*> \htmlonly
*> Download CUNM2L + dependencies
*>
*> [TGZ]
@@ -13,7 +12,6 @@
*> [ZIP]
*>
*> [TXT]
-*> \endhtmlonly
*
* Definition:
* ===========
@@ -151,11 +149,12 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \ingroup complexOTHERcomputational
+*> \ingroup unm2l
*
* =====================================================================
SUBROUTINE CUNM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
$ WORK, INFO )
+ IMPLICIT NONE
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
@@ -171,21 +170,17 @@ SUBROUTINE CUNM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
*
* =====================================================================
*
-* .. Parameters ..
- COMPLEX ONE
- PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ) )
-* ..
* .. Local Scalars ..
LOGICAL LEFT, NOTRAN
INTEGER I, I1, I2, I3, MI, NI, NQ
- COMPLEX AII, TAUI
+ COMPLEX TAUI
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
- EXTERNAL CLARF, XERBLA
+ EXTERNAL CLARF1L, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC CONJG, MAX
@@ -266,10 +261,8 @@ SUBROUTINE CUNM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
ELSE
TAUI = CONJG( TAU( I ) )
END IF
- AII = A( NQ-K+I, I )
- A( NQ-K+I, I ) = ONE
- CALL CLARF( SIDE, MI, NI, A( 1, I ), 1, TAUI, C, LDC, WORK )
- A( NQ-K+I, I ) = AII
+ CALL CLARF1L( SIDE, MI, NI, A( 1, I ), 1, TAUI, C, LDC,
+ $ WORK )
10 CONTINUE
RETURN
*
diff --git a/lapack-netlib/SRC/cunm2r.f b/lapack-netlib/SRC/cunm2r.f
index a79e9a78d0..c357356235 100644
--- a/lapack-netlib/SRC/cunm2r.f
+++ b/lapack-netlib/SRC/cunm2r.f
@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
-*> \htmlonly
*> Download CUNM2R + dependencies
*>
*> [TGZ]
@@ -13,7 +12,6 @@
*> [ZIP]
*>
*> [TXT]
-*> \endhtmlonly
*
* Definition:
* ===========
@@ -151,11 +149,12 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \ingroup complexOTHERcomputational
+*> \ingroup unm2r
*
* =====================================================================
SUBROUTINE CUNM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
$ WORK, INFO )
+ IMPLICIT NONE
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
@@ -171,21 +170,17 @@ SUBROUTINE CUNM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
*
* =====================================================================
*
-* .. Parameters ..
- COMPLEX ONE
- PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ) )
-* ..
* .. Local Scalars ..
LOGICAL LEFT, NOTRAN
INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ
- COMPLEX AII, TAUI
+ COMPLEX TAUI
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
- EXTERNAL CLARF, XERBLA
+ EXTERNAL CLARF1F, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC CONJG, MAX
@@ -270,11 +265,8 @@ SUBROUTINE CUNM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
ELSE
TAUI = CONJG( TAU( I ) )
END IF
- AII = A( I, I )
- A( I, I ) = ONE
- CALL CLARF( SIDE, MI, NI, A( I, I ), 1, TAUI, C( IC, JC ), LDC,
- $ WORK )
- A( I, I ) = AII
+ CALL CLARF1F( SIDE, MI, NI, A( I, I ), 1, TAUI, C( IC, JC ),
+ $ LDC, WORK )
10 CONTINUE
RETURN
*
diff --git a/lapack-netlib/SRC/cunml2.f b/lapack-netlib/SRC/cunml2.f
index 6af8cc0358..edd0a39ef2 100644
--- a/lapack-netlib/SRC/cunml2.f
+++ b/lapack-netlib/SRC/cunml2.f
@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
-*> \htmlonly
*> Download CUNML2 + dependencies
*>
*> [TGZ]
@@ -13,7 +12,6 @@
*> [ZIP]
*>
*> [TXT]
-*> \endhtmlonly
*
* Definition:
* ===========
@@ -151,11 +149,12 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \ingroup complexOTHERcomputational
+*> \ingroup unml2
*
* =====================================================================
SUBROUTINE CUNML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
$ WORK, INFO )
+ IMPLICIT NONE
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
@@ -171,21 +170,17 @@ SUBROUTINE CUNML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
*
* =====================================================================
*
-* .. Parameters ..
- COMPLEX ONE
- PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ) )
-* ..
* .. Local Scalars ..
LOGICAL LEFT, NOTRAN
INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ
- COMPLEX AII, TAUI
+ COMPLEX TAUI
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
- EXTERNAL CLACGV, CLARF, XERBLA
+ EXTERNAL CLACGV, CLARF1F, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC CONJG, MAX
@@ -272,11 +267,8 @@ SUBROUTINE CUNML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
END IF
IF( I.LT.NQ )
$ CALL CLACGV( NQ-I, A( I, I+1 ), LDA )
- AII = A( I, I )
- A( I, I ) = ONE
- CALL CLARF( SIDE, MI, NI, A( I, I ), LDA, TAUI, C( IC, JC ),
- $ LDC, WORK )
- A( I, I ) = AII
+ CALL CLARF1F( SIDE, MI, NI, A( I, I ), LDA, TAUI, C( IC,
+ $ JC ), LDC, WORK )
IF( I.LT.NQ )
$ CALL CLACGV( NQ-I, A( I, I+1 ), LDA )
10 CONTINUE
diff --git a/lapack-netlib/SRC/cunmr2.f b/lapack-netlib/SRC/cunmr2.f
index ebd4cfbb64..ca4f9fd6f8 100644
--- a/lapack-netlib/SRC/cunmr2.f
+++ b/lapack-netlib/SRC/cunmr2.f
@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
-*> \htmlonly
*> Download CUNMR2 + dependencies
*>
*> [TGZ]
@@ -13,7 +12,6 @@
*> [ZIP]
*>
*> [TXT]
-*> \endhtmlonly
*
* Definition:
* ===========
@@ -151,11 +149,12 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \ingroup complexOTHERcomputational
+*> \ingroup unmr2
*
* =====================================================================
SUBROUTINE CUNMR2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
$ WORK, INFO )
+ IMPLICIT NONE
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
@@ -171,21 +170,17 @@ SUBROUTINE CUNMR2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
*
* =====================================================================
*
-* .. Parameters ..
- COMPLEX ONE
- PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ) )
-* ..
* .. Local Scalars ..
LOGICAL LEFT, NOTRAN
INTEGER I, I1, I2, I3, MI, NI, NQ
- COMPLEX AII, TAUI
+ COMPLEX TAUI
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
- EXTERNAL CLACGV, CLARF, XERBLA
+ EXTERNAL CLACGV, CLARF1L, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC CONJG, MAX
@@ -267,10 +262,8 @@ SUBROUTINE CUNMR2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
TAUI = TAU( I )
END IF
CALL CLACGV( NQ-K+I-1, A( I, 1 ), LDA )
- AII = A( I, NQ-K+I )
- A( I, NQ-K+I ) = ONE
- CALL CLARF( SIDE, MI, NI, A( I, 1 ), LDA, TAUI, C, LDC, WORK )
- A( I, NQ-K+I ) = AII
+ CALL CLARF1L( SIDE, MI, NI, A( I, 1 ), LDA, TAUI, C, LDC,
+ $ WORK )
CALL CLACGV( NQ-K+I-1, A( I, 1 ), LDA )
10 CONTINUE
RETURN
diff --git a/lapack-netlib/SRC/cupmtr.f b/lapack-netlib/SRC/cupmtr.f
index 2629e91792..b4fb38e854 100644
--- a/lapack-netlib/SRC/cupmtr.f
+++ b/lapack-netlib/SRC/cupmtr.f
@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
-*> \htmlonly
*> Download CUPMTR + dependencies
*>
*> [TGZ]
@@ -13,7 +12,6 @@
*> [ZIP]
*>
*> [TXT]
-*> \endhtmlonly
*
* Definition:
* ===========
@@ -142,11 +140,13 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \ingroup complexOTHERcomputational
+*> \ingroup upmtr
*
* =====================================================================
- SUBROUTINE CUPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC, WORK,
+ SUBROUTINE CUPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC,
+ $ WORK,
$ INFO )
+ IMPLICIT NONE
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
@@ -162,21 +162,17 @@ SUBROUTINE CUPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC, WORK,
*
* =====================================================================
*
-* .. Parameters ..
- COMPLEX ONE
- PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ) )
-* ..
* .. Local Scalars ..
LOGICAL FORWRD, LEFT, NOTRAN, UPPER
INTEGER I, I1, I2, I3, IC, II, JC, MI, NI, NQ
- COMPLEX AII, TAUI
+ COMPLEX TAUI
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
- EXTERNAL CLARF, XERBLA
+ EXTERNAL CLARF1F, CLARF1L, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC CONJG, MAX
@@ -265,11 +261,8 @@ SUBROUTINE CUPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC, WORK,
ELSE
TAUI = CONJG( TAU( I ) )
END IF
- AII = AP( II )
- AP( II ) = ONE
- CALL CLARF( SIDE, MI, NI, AP( II-I+1 ), 1, TAUI, C, LDC,
- $ WORK )
- AP( II ) = AII
+ CALL CLARF1L( SIDE, MI, NI, AP( II-I+1 ), 1, TAUI, C,
+ $ LDC, WORK )
*
IF( FORWRD ) THEN
II = II + I + 2
@@ -305,8 +298,6 @@ SUBROUTINE CUPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC, WORK,
END IF
*
DO 20 I = I1, I2, I3
- AII = AP( II )
- AP( II ) = ONE
IF( LEFT ) THEN
*
* H(i) or H(i)**H is applied to C(i+1:m,1:n)
@@ -328,9 +319,8 @@ SUBROUTINE CUPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC, WORK,
ELSE
TAUI = CONJG( TAU( I ) )
END IF
- CALL CLARF( SIDE, MI, NI, AP( II ), 1, TAUI, C( IC, JC ),
- $ LDC, WORK )
- AP( II ) = AII
+ CALL CLARF1F( SIDE, MI, NI, AP( II ), 1, TAUI, C( IC,
+ $ JC ), LDC, WORK )
*
IF( FORWRD ) THEN
II = II + NQ - I + 1
diff --git a/lapack-netlib/SRC/dgebd2.f b/lapack-netlib/SRC/dgebd2.f
index daaa187aff..b94bcc4784 100644
--- a/lapack-netlib/SRC/dgebd2.f
+++ b/lapack-netlib/SRC/dgebd2.f
@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
-*> \htmlonly
*> Download DGEBD2 + dependencies
*>
*> [TGZ]
@@ -13,7 +12,6 @@
*> [ZIP]
*>
*> [TXT]
-*> \endhtmlonly
*
* Definition:
* ===========
@@ -132,7 +130,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \ingroup doubleGEcomputational
+*> \ingroup gebd2
*
*> \par Further Details:
* =====================
@@ -186,6 +184,7 @@
*>
* =====================================================================
SUBROUTINE DGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO )
+ IMPLICIT NONE
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
@@ -202,14 +201,14 @@ SUBROUTINE DGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO )
* =====================================================================
*
* .. Parameters ..
- DOUBLE PRECISION ZERO, ONE
- PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+ DOUBLE PRECISION ZERO
+ PARAMETER ( ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I
* ..
* .. External Subroutines ..
- EXTERNAL DLARF, DLARFG, XERBLA
+ EXTERNAL DLARF1F, DLARFG, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
@@ -242,14 +241,13 @@ SUBROUTINE DGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO )
CALL DLARFG( 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 DLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAUQ( I ),
+ $ CALL DLARF1F( 'Left', M-I+1, N-I, A( I, I ), 1,
+ $ TAUQ( I ),
$ A( I, I+1 ), LDA, WORK )
- A( I, I ) = D( I )
*
IF( I.LT.N ) THEN
*
@@ -259,13 +257,11 @@ SUBROUTINE DGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO )
CALL DLARFG( 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 DLARF( 'Right', M-I, N-I, A( I, I+1 ), LDA,
+ CALL DLARF1F( '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 )
ELSE
TAUP( I ) = ZERO
END IF
@@ -278,33 +274,32 @@ SUBROUTINE DGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO )
*
* Generate elementary reflector G(i) to annihilate A(i,i+1:n)
*
- CALL DLARFG( N-I+1, A( I, I ), A( I, MIN( I+1, N ) ), LDA,
+ CALL DLARFG( N-I+1, A( I, I ), A( I, MIN( I+1, N ) ),
+ $ 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 DLARF( 'Right', M-I, N-I+1, A( I, I ), LDA,
+ $ CALL DLARF1F( 'Right', M-I, N-I+1, A( I, I ), LDA,
$ TAUP( I ), A( I+1, I ), LDA, WORK )
- A( I, I ) = D( I )
*
IF( I.LT.M ) THEN
*
* Generate elementary reflector H(i) to annihilate
* A(i+2:m,i)
*
- CALL DLARFG( M-I, A( I+1, I ), A( MIN( I+2, M ), I ), 1,
+ CALL DLARFG( M-I, A( I+1, I ), A( MIN( I+2, M ), I ),
+ $ 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 DLARF( 'Left', M-I, N-I, A( I+1, I ), 1, TAUQ( I ),
+ CALL DLARF1F( '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 )
ELSE
TAUQ( I ) = ZERO
END IF
diff --git a/lapack-netlib/SRC/dgehd2.f b/lapack-netlib/SRC/dgehd2.f
index c71e38433f..eaaf091a60 100644
--- a/lapack-netlib/SRC/dgehd2.f
+++ b/lapack-netlib/SRC/dgehd2.f
@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
-*> \htmlonly
*> Download DGEHD2 + dependencies
*>
*> [TGZ]
@@ -13,7 +12,6 @@
*> [ZIP]
*>
*> [TXT]
-*> \endhtmlonly
*
* Definition:
* ===========
@@ -106,7 +104,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \ingroup doubleGEcomputational
+*> \ingroup gehd2
*
*> \par Further Details:
* =====================
@@ -146,6 +144,7 @@
*>
* =====================================================================
SUBROUTINE DGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO )
+ IMPLICIT NONE
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
@@ -166,10 +165,9 @@ SUBROUTINE DGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO )
* ..
* .. Local Scalars ..
INTEGER I
- DOUBLE PRECISION AII
* ..
* .. External Subroutines ..
- EXTERNAL DLARF, DLARFG, XERBLA
+ EXTERNAL DLARF1F, DLARFG, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
@@ -199,20 +197,17 @@ SUBROUTINE DGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO )
*
CALL DLARFG( 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 DLARF( 'Right', IHI, IHI-I, A( I+1, I ), 1, TAU( I ),
+ CALL DLARF1F( '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 DLARF( 'Left', IHI-I, N-I, A( I+1, I ), 1, TAU( I ),
+ CALL DLARF1F( '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/lapack-netlib/SRC/dgelq2.f b/lapack-netlib/SRC/dgelq2.f
index 9915c57d47..b7c8c933d8 100644
--- a/lapack-netlib/SRC/dgelq2.f
+++ b/lapack-netlib/SRC/dgelq2.f
@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
-*> \htmlonly
*> Download DGELQ2 + dependencies
*>
*> [TGZ]
@@ -13,7 +12,6 @@
*> [ZIP]
*>
*> [TXT]
-*> \endhtmlonly
*
* Definition:
* ===========
@@ -104,7 +102,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \ingroup doubleGEcomputational
+*> \ingroup gelq2
*
*> \par Further Details:
* =====================
@@ -126,6 +124,7 @@
*>
* =====================================================================
SUBROUTINE DGELQ2( M, N, A, LDA, TAU, WORK, INFO )
+ IMPLICIT NONE
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
@@ -146,10 +145,9 @@ SUBROUTINE DGELQ2( M, N, A, LDA, TAU, WORK, INFO )
* ..
* .. Local Scalars ..
INTEGER I, K
- DOUBLE PRECISION AII
* ..
* .. External Subroutines ..
- EXTERNAL DLARF, DLARFG, XERBLA
+ EXTERNAL DLARF1F, DLARFG, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
@@ -183,11 +181,9 @@ SUBROUTINE DGELQ2( 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 DLARF( 'Right', M-I, N-I+1, A( I, I ), LDA, TAU( I ),
+ CALL DLARF1F( 'Right', M-I, N-I+1, A( I, I ), LDA,
+ $ TAU( I ),
$ A( I+1, I ), LDA, WORK )
- A( I, I ) = AII
END IF
10 CONTINUE
RETURN
diff --git a/lapack-netlib/SRC/dgeql2.f b/lapack-netlib/SRC/dgeql2.f
index 2d3ce1419f..1b2f55a658 100644
--- a/lapack-netlib/SRC/dgeql2.f
+++ b/lapack-netlib/SRC/dgeql2.f
@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
-*> \htmlonly
*> Download DGEQL2 + dependencies
*>
*> [TGZ]
@@ -13,7 +12,6 @@
*> [ZIP]
*>
*> [TXT]
-*> \endhtmlonly
*
* Definition:
* ===========
@@ -98,7 +96,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \ingroup doubleGEcomputational
+*> \ingroup geql2
*
*> \par Further Details:
* =====================
@@ -120,6 +118,7 @@
*>
* =====================================================================
SUBROUTINE DGEQL2( M, N, A, LDA, TAU, WORK, INFO )
+ IMPLICIT NONE
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
@@ -140,10 +139,9 @@ SUBROUTINE DGEQL2( M, N, A, LDA, TAU, WORK, INFO )
* ..
* .. Local Scalars ..
INTEGER I, K
- DOUBLE PRECISION AII
* ..
* .. External Subroutines ..
- EXTERNAL DLARF, DLARFG, XERBLA
+ EXTERNAL DLARF1L, DLARFG, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
@@ -177,11 +175,9 @@ SUBROUTINE DGEQL2( 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 DLARF( 'Left', M-K+I, N-K+I-1, A( 1, N-K+I ), 1, TAU( I ),
+ CALL DLARF1L( '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
10 CONTINUE
RETURN
*
diff --git a/lapack-netlib/SRC/dgeqp3rk.f b/lapack-netlib/SRC/dgeqp3rk.f
index b8e41b39cd..8645f88ebb 100644
--- a/lapack-netlib/SRC/dgeqp3rk.f
+++ b/lapack-netlib/SRC/dgeqp3rk.f
@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
-*> \htmlonly
*> Download DGEQP3RK + dependencies
*>
*> [TGZ]
@@ -13,7 +12,6 @@
*> [ZIP]
*>
*> [TXT]
-*> \endhtmlonly
*
* Definition:
* ===========
@@ -546,27 +544,19 @@
*> C. H. Bischof, Math. and Comp. Sci. Div., Argonne National Lab, USA.
*> A BLAS-3 version of the QR factorization with column pivoting.
*> LAPACK Working Note 114
-*> \htmlonly
*> https://www.netlib.org/lapack/lawnspdf/lawn114.pdf
-*> \endhtmlonly
*> and in
*> SIAM J. Sci. Comput., 19(5):1486-1494, Sept. 1998.
-*> \htmlonly
*> https://doi.org/10.1137/S1064827595296732
-*> \endhtmlonly
*>
*> [2] A partial column norm updating strategy developed in 2006.
*> Z. Drmac and Z. Bujanovic, Dept. of Math., University of Zagreb, Croatia.
*> On the failure of rank revealing QR factorization software – a case study.
*> LAPACK Working Note 176.
-*> \htmlonly
*> http://www.netlib.org/lapack/lawnspdf/lawn176.pdf
-*> \endhtmlonly
*> and in
*> ACM Trans. Math. Softw. 35, 2, Article 12 (July 2008), 28 pages.
-*> \htmlonly
*> https://doi.org/10.1145/1377612.1377616
-*> \endhtmlonly
*
*> \par Contributors:
* ==================
@@ -670,7 +660,7 @@ SUBROUTINE DGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, A, LDA,
* 1) DGEQP3RK and DLAQP2RK: 2*N to store full and partial
* column 2-norms.
* 2) DLAQP2RK: N+NRHS-1 to use in WORK array that is used
-* in DLARF subroutine inside DLAQP2RK to apply an
+* in DLARF1F subroutine inside DLAQP2RK to apply an
* elementary reflector from the left.
* TOTAL_WORK_SIZE = 3*N + NRHS - 1
*
@@ -686,7 +676,7 @@ SUBROUTINE DGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, A, LDA,
* 1) DGEQP3RK, DLAQP2RK, DLAQP3RK: 2*N to store full and
* partial column 2-norms.
* 2) DLAQP2RK: N+NRHS-1 to use in WORK array that is used
-* in DLARF subroutine to apply an elementary reflector
+* in DLARF1F subroutine to apply an elementary reflector
* from the left.
* 3) DLAQP3RK: NB*(N+NRHS) to use in the work array F that
* is used to apply a block reflector from
@@ -886,7 +876,8 @@ SUBROUTINE DGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, A, LDA,
* Determine when to cross over from blocked to unblocked code.
* (for N less than NX, unblocked code should be used).
*
- NX = MAX( 0, ILAENV( IXOVER, 'DGEQP3RK', ' ', M, N, -1, -1 ))
+ NX = MAX( 0, ILAENV( IXOVER, 'DGEQP3RK', ' ', M, N, -1,
+ $ -1 ))
*
IF( NX.LT.MINMN ) THEN
*
diff --git a/lapack-netlib/SRC/dgeqr2.f b/lapack-netlib/SRC/dgeqr2.f
index 5791b3a915..94872f54e6 100644
--- a/lapack-netlib/SRC/dgeqr2.f
+++ b/lapack-netlib/SRC/dgeqr2.f
@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
-*> \htmlonly
*> Download DGEQR2 + dependencies
*>
*> [TGZ]
@@ -13,7 +12,6 @@
*> [ZIP]
*>
*> [TXT]
-*> \endhtmlonly
*
* Definition:
* ===========
@@ -105,7 +103,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \ingroup doubleGEcomputational
+*> \ingroup geqr2
*
*> \par Further Details:
* =====================
@@ -127,6 +125,7 @@
*>
* =====================================================================
SUBROUTINE DGEQR2( M, N, A, LDA, TAU, WORK, INFO )
+ IMPLICIT NONE
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
@@ -147,10 +146,9 @@ SUBROUTINE DGEQR2( M, N, A, LDA, TAU, WORK, INFO )
* ..
* .. Local Scalars ..
INTEGER I, K
- DOUBLE PRECISION AII
* ..
* .. External Subroutines ..
- EXTERNAL DLARF, DLARFG, XERBLA
+ EXTERNAL DLARF1F, DLARFG, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
@@ -184,11 +182,8 @@ SUBROUTINE DGEQR2( 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 DLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ),
+ CALL DLARF1F( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ),
$ A( I, I+1 ), LDA, WORK )
- A( I, I ) = AII
END IF
10 CONTINUE
RETURN
diff --git a/lapack-netlib/SRC/dgeqr2p.f b/lapack-netlib/SRC/dgeqr2p.f
index c7b62d87d7..cce4d346ea 100644
--- a/lapack-netlib/SRC/dgeqr2p.f
+++ b/lapack-netlib/SRC/dgeqr2p.f
@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
-*> \htmlonly
*> Download DGEQR2P + dependencies
*>
*> [TGZ]
@@ -13,7 +12,6 @@
*> [ZIP]
*>
*> [TXT]
-*> \endhtmlonly
*
* Definition:
* ===========
@@ -107,7 +105,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \ingroup doubleGEcomputational
+*> \ingroup geqr2p
*
*> \par Further Details:
* =====================
@@ -131,6 +129,7 @@
*>
* =====================================================================
SUBROUTINE DGEQR2P( M, N, A, LDA, TAU, WORK, INFO )
+ IMPLICIT NONE
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
@@ -151,10 +150,9 @@ SUBROUTINE DGEQR2P( M, N, A, LDA, TAU, WORK, INFO )
* ..
* .. Local Scalars ..
INTEGER I, K
- DOUBLE PRECISION AII
* ..
* .. External Subroutines ..
- EXTERNAL DLARF, DLARFGP, XERBLA
+ EXTERNAL DLARF1F, DLARFGP, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
@@ -188,11 +186,8 @@ SUBROUTINE DGEQR2P( 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 DLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ),
+ CALL DLARF1F( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ),
$ A( I, I+1 ), LDA, WORK )
- A( I, I ) = AII
END IF
10 CONTINUE
RETURN
diff --git a/lapack-netlib/SRC/dgerq2.f b/lapack-netlib/SRC/dgerq2.f
index 97d33761da..23ff2d068c 100644
--- a/lapack-netlib/SRC/dgerq2.f
+++ b/lapack-netlib/SRC/dgerq2.f
@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
-*> \htmlonly
*> Download DGERQ2 + dependencies
*>
*> [TGZ]
@@ -13,7 +12,6 @@
*> [ZIP]
*>
*> [TXT]
-*> \endhtmlonly
*
* Definition:
* ===========
@@ -98,7 +96,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \ingroup doubleGEcomputational
+*> \ingroup gerq2
*
*> \par Further Details:
* =====================
@@ -120,6 +118,7 @@
*>
* =====================================================================
SUBROUTINE DGERQ2( M, N, A, LDA, TAU, WORK, INFO )
+ IMPLICIT NONE
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
@@ -140,10 +139,9 @@ SUBROUTINE DGERQ2( M, N, A, LDA, TAU, WORK, INFO )
* ..
* .. Local Scalars ..
INTEGER I, K
- DOUBLE PRECISION AII
* ..
* .. External Subroutines ..
- EXTERNAL DLARF, DLARFG, XERBLA
+ EXTERNAL DLARF1L, DLARFG, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
@@ -177,11 +175,8 @@ SUBROUTINE DGERQ2( 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 DLARF( 'Right', M-K+I-1, N-K+I, A( M-K+I, 1 ), LDA,
+ CALL DLARF1L( '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
10 CONTINUE
RETURN
*
diff --git a/lapack-netlib/SRC/dlaqp2.f b/lapack-netlib/SRC/dlaqp2.f
index b99de6d7d5..d32f075484 100644
--- a/lapack-netlib/SRC/dlaqp2.f
+++ b/lapack-netlib/SRC/dlaqp2.f
@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
-*> \htmlonly
*> Download DLAQP2 + dependencies
*>
*> [TGZ]
@@ -13,7 +12,6 @@
*> [ZIP]
*>
*> [TXT]
-*> \endhtmlonly
*
* Definition:
* ===========
@@ -122,7 +120,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \ingroup doubleOTHERauxiliary
+*> \ingroup laqp2
*
*> \par Contributors:
* ==================
@@ -139,13 +137,12 @@
*>
*> LAPACK Working Note 176
*
-*> \htmlonly
*> [PDF]
-*> \endhtmlonly
*
* =====================================================================
SUBROUTINE DLAQP2( M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2,
$ WORK )
+ IMPLICIT NONE
*
* -- LAPACK auxiliary routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
@@ -168,7 +165,7 @@ SUBROUTINE DLAQP2( M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2,
* ..
* .. Local Scalars ..
INTEGER I, ITEMP, J, MN, OFFPI, PVT
- DOUBLE PRECISION AII, TEMP, TEMP2, TOL3Z
+ DOUBLE PRECISION TEMP, TEMP2, TOL3Z
* ..
* .. External Subroutines ..
EXTERNAL DLARF, DLARFG, DSWAP
@@ -208,7 +205,8 @@ SUBROUTINE DLAQP2( M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2,
* Generate elementary reflector H(i).
*
IF( OFFPI.LT.M ) THEN
- CALL DLARFG( M-OFFPI+1, A( OFFPI, I ), A( OFFPI+1, I ), 1,
+ CALL DLARFG( M-OFFPI+1, A( OFFPI, I ), A( OFFPI+1, I ),
+ $ 1,
$ TAU( I ) )
ELSE
CALL DLARFG( 1, A( M, I ), A( M, I ), 1, TAU( I ) )
@@ -218,11 +216,8 @@ SUBROUTINE DLAQP2( 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 DLARF( 'Left', M-OFFPI+1, N-I, A( OFFPI, I ), 1,
+ CALL DLARF1F( 'Left', M-OFFPI+1, N-I, A( OFFPI, I ), 1,
$ TAU( I ), A( OFFPI, I+1 ), LDA, WORK( 1 ) )
- A( OFFPI, I ) = AII
END IF
*
* Update partial column norms.
diff --git a/lapack-netlib/SRC/dlaqp2rk.f b/lapack-netlib/SRC/dlaqp2rk.f
index aecd6bb69c..ae2d62cac5 100644
--- a/lapack-netlib/SRC/dlaqp2rk.f
+++ b/lapack-netlib/SRC/dlaqp2rk.f
@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
-*> \htmlonly
*> Download DLAQP2RK + dependencies
*>
*> [TGZ]
@@ -13,7 +12,6 @@
*> [ZIP]
*>
*> [TXT]
-*> \endhtmlonly
*
* Definition:
* ===========
@@ -253,7 +251,7 @@
*> \param[out] WORK
*> \verbatim
*> WORK is DOUBLE PRECISION array, dimension (N-1)
-*> Used in DLARF subroutine to apply an elementary
+*> Used in DLARF1F subroutine to apply an elementary
*> reflector from the left.
*> \endverbatim
*>
@@ -303,27 +301,19 @@
*> C. H. Bischof, Math. and Comp. Sci. Div., Argonne National Lab, USA.
*> A BLAS-3 version of the QR factorization with column pivoting.
*> LAPACK Working Note 114
-*> \htmlonly
*> https://www.netlib.org/lapack/lawnspdf/lawn114.pdf
-*> \endhtmlonly
*> and in
*> SIAM J. Sci. Comput., 19(5):1486-1494, Sept. 1998.
-*> \htmlonly
*> https://doi.org/10.1137/S1064827595296732
-*> \endhtmlonly
*>
*> [2] A partial column norm updating strategy developed in 2006.
*> Z. Drmac and Z. Bujanovic, Dept. of Math., University of Zagreb, Croatia.
*> On the failure of rank revealing QR factorization software – a case study.
*> LAPACK Working Note 176.
-*> \htmlonly
*> http://www.netlib.org/lapack/lawnspdf/lawn176.pdf
-*> \endhtmlonly
*> and in
*> ACM Trans. Math. Softw. 35, 2, Article 12 (July 2008), 28 pages.
-*> \htmlonly
*> https://doi.org/10.1145/1377612.1377616
-*> \endhtmlonly
*
*> \par Contributors:
* ==================
@@ -365,12 +355,12 @@ SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL,
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
- INTEGER I, ITEMP, J, JMAXC2NRM, KK, KP, MINMNFACT,
- $ MINMNUPDT
- DOUBLE PRECISION AIKK, HUGEVAL, TEMP, TEMP2, TOL3Z
+ INTEGER I, ITEMP, J, JMAXC2NRM, KK, KP,
+ $ KBOUND, MINMNFACT, MINMNUPDT
+ DOUBLE PRECISION HUGEVAL, TEMP, TEMP2, TOL3Z
* ..
* .. External Subroutines ..
- EXTERNAL DLARF, DLARFG, DSWAP
+ EXTERNAL DLARF1F, DLARFG, DSWAP
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, SQRT
@@ -397,13 +387,13 @@ SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL,
*
MINMNFACT = MIN( M-IOFFSET, N )
MINMNUPDT = MIN( M-IOFFSET, N+NRHS )
- KMAX = MIN( KMAX, MINMNFACT )
+ KBOUND = MIN( KMAX, MINMNFACT )
TOL3Z = SQRT( DLAMCH( 'Epsilon' ) )
HUGEVAL = DLAMCH( 'Overflow' )
*
* Compute the factorization, KK is the lomn loop index.
*
- DO KK = 1, KMAX
+ DO KK = 1, KBOUND
*
I = IOFFSET + KK
*
@@ -621,11 +611,8 @@ SUBROUTINE DLAQP2RK( 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 DLARF( 'Left', M-I+1, N+NRHS-KK, A( I, KK ), 1,
+ CALL DLARF1F( 'Left', M-I+1, N+NRHS-KK, A( I, KK ), 1,
$ TAU( KK ), A( I, KK+1 ), LDA, WORK( 1 ) )
- A( I, KK ) = AIKK
END IF
*
IF( KK.LT.MINMNFACT ) THEN
@@ -676,7 +663,7 @@ SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL,
* i.e. no condition was triggered to exit the routine.
* Set the number of factorized columns.
*
- K = KMAX
+ K = KBOUND
*
* We reached the end of the loop, i.e. all KMAX columns were
* factorized, we need to set MAXC2NRMK and RELMAXC2NRMK before
diff --git a/lapack-netlib/SRC/dlaqr2.f b/lapack-netlib/SRC/dlaqr2.f
index 515c836582..02ae83cb5d 100644
--- a/lapack-netlib/SRC/dlaqr2.f
+++ b/lapack-netlib/SRC/dlaqr2.f
@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
-*> \htmlonly
*> Download DLAQR2 + dependencies
*>
*> [TGZ]
@@ -13,7 +12,6 @@
*> [ZIP]
*>
*> [TXT]
-*> \endhtmlonly
*
* Definition:
* ===========
@@ -263,7 +261,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \ingroup doubleOTHERauxiliary
+*> \ingroup laqr2
*
*> \par Contributors:
* ==================
@@ -272,9 +270,11 @@
*> University of Kansas, USA
*>
* =====================================================================
- SUBROUTINE DLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
+ SUBROUTINE DLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH,
+ $ ILOZ,
$ IHIZ, Z, LDZ, NS, ND, SR, SI, V, LDV, NH, T,
$ LDT, NV, WV, LDWV, WORK, LWORK )
+ IMPLICIT NONE
*
* -- LAPACK auxiliary routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
@@ -309,8 +309,9 @@ SUBROUTINE DLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
EXTERNAL DLAMCH
* ..
* .. External Subroutines ..
- EXTERNAL DCOPY, DGEHRD, DGEMM, DLABAD, DLACPY, DLAHQR,
- $ DLANV2, DLARF, DLARFG, DLASET, DORMHR, DTREXC
+ EXTERNAL DCOPY, DGEHRD, DGEMM, DLACPY,
+ $ DLAHQR,
+ $ DLANV2, DLARF1F, DLARFG, DLASET, DORMHR, DTREXC
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, INT, MAX, MIN, SQRT
@@ -331,7 +332,8 @@ SUBROUTINE DLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
*
* ==== Workspace query call to DORMHR ====
*
- CALL DORMHR( 'R', 'N', JW, JW, 1, JW-1, T, LDT, WORK, V, LDV,
+ CALL DORMHR( 'R', 'N', JW, JW, 1, JW-1, T, LDT, WORK, V,
+ $ LDV,
$ WORK, -1, INFO )
LWK2 = INT( WORK( 1 ) )
*
@@ -362,7 +364,6 @@ SUBROUTINE DLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
*
SAFMIN = DLAMCH( 'SAFE MINIMUM' )
SAFMAX = ONE / SAFMIN
- CALL DLABAD( SAFMIN, SAFMAX )
ULP = DLAMCH( 'PRECISION' )
SMLNUM = SAFMIN*( DBLE( N ) / ULP )
*
@@ -402,7 +403,8 @@ SUBROUTINE DLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
* . here and there to keep track.) ====
*
CALL DLACPY( 'U', JW, JW, H( KWTOP, KWTOP ), LDH, T, LDT )
- CALL DCOPY( JW-1, H( KWTOP+1, KWTOP ), LDH+1, T( 2, 1 ), LDT+1 )
+ CALL DCOPY( JW-1, H( KWTOP+1, KWTOP ), LDH+1, T( 2, 1 ),
+ $ LDT+1 )
*
CALL DLASET( 'A', JW, JW, ZERO, ONE, V, LDV )
CALL DLAHQR( .true., .true., JW, 1, JW, T, LDT, SR( KWTOP ),
@@ -449,7 +451,8 @@ SUBROUTINE DLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
* . (DTREXC can not fail in this case.) ====
*
IFST = NS
- CALL DTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, WORK,
+ CALL DTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST,
+ $ WORK,
$ INFO )
ILST = ILST + 1
END IF
@@ -474,7 +477,8 @@ SUBROUTINE DLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
* . ILST in case of a rare exchange failure. ====
*
IFST = NS
- CALL DTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, WORK,
+ CALL DTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST,
+ $ WORK,
$ INFO )
ILST = ILST + 2
END IF
@@ -536,7 +540,8 @@ SUBROUTINE DLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
SORTED = .false.
IFST = I
ILST = K
- CALL DTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, WORK,
+ CALL DTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST,
+ $ WORK,
$ INFO )
IF( INFO.EQ.0 ) THEN
I = ILST
@@ -591,15 +596,15 @@ SUBROUTINE DLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
CALL DCOPY( NS, V, LDV, WORK, 1 )
BETA = WORK( 1 )
CALL DLARFG( NS, BETA, WORK( 2 ), 1, TAU )
- WORK( 1 ) = ONE
*
- CALL DLASET( 'L', JW-2, JW-2, ZERO, ZERO, T( 3, 1 ), LDT )
+ CALL DLASET( 'L', JW-2, JW-2, ZERO, ZERO, T( 3, 1 ),
+ $ LDT )
*
- CALL DLARF( 'L', NS, JW, WORK, 1, TAU, T, LDT,
+ CALL DLARF1F( 'L', NS, JW, WORK, 1, TAU, T, LDT,
$ WORK( JW+1 ) )
- CALL DLARF( 'R', NS, NS, WORK, 1, TAU, T, LDT,
+ CALL DLARF1F( 'R', NS, NS, WORK, 1, TAU, T, LDT,
$ WORK( JW+1 ) )
- CALL DLARF( 'R', JW, NS, WORK, 1, TAU, V, LDV,
+ CALL DLARF1F( 'R', JW, NS, WORK, 1, TAU, V, LDV,
$ WORK( JW+1 ) )
*
CALL DGEHRD( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ),
@@ -618,7 +623,8 @@ SUBROUTINE DLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
* . H and Z, if requested. ====
*
IF( NS.GT.1 .AND. S.NE.ZERO )
- $ CALL DORMHR( 'R', 'N', JW, NS, 1, NS, T, LDT, WORK, V, LDV,
+ $ CALL DORMHR( 'R', 'N', JW, NS, 1, NS, T, LDT, WORK, V,
+ $ LDV,
$ WORK( JW+1 ), LWORK-JW, INFO )
*
* ==== Update vertical slab in H ====
@@ -632,7 +638,8 @@ SUBROUTINE DLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
KLN = MIN( NV, KWTOP-KROW )
CALL DGEMM( 'N', 'N', KLN, JW, JW, ONE, H( KROW, KWTOP ),
$ LDH, V, LDV, ZERO, WV, LDWV )
- CALL DLACPY( 'A', KLN, JW, WV, LDWV, H( KROW, KWTOP ), LDH )
+ CALL DLACPY( 'A', KLN, JW, WV, LDWV, H( KROW, KWTOP ),
+ $ LDH )
70 CONTINUE
*
* ==== Update horizontal slab in H ====
@@ -652,7 +659,8 @@ SUBROUTINE DLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
IF( WANTZ ) THEN
DO 90 KROW = ILOZ, IHIZ, NV
KLN = MIN( NV, IHIZ-KROW+1 )
- CALL DGEMM( 'N', 'N', KLN, JW, JW, ONE, Z( KROW, KWTOP ),
+ CALL DGEMM( 'N', 'N', KLN, JW, JW, ONE, Z( KROW,
+ $ KWTOP ),
$ LDZ, V, LDV, ZERO, WV, LDWV )
CALL DLACPY( 'A', KLN, JW, WV, LDWV, Z( KROW, KWTOP ),
$ LDZ )
diff --git a/lapack-netlib/SRC/dlaqr3.f b/lapack-netlib/SRC/dlaqr3.f
index 36e08f02e8..9ddd8c7a4a 100644
--- a/lapack-netlib/SRC/dlaqr3.f
+++ b/lapack-netlib/SRC/dlaqr3.f
@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
-*> \htmlonly
*> Download DLAQR3 + dependencies
*>
*> [TGZ]
@@ -13,7 +12,6 @@
*> [ZIP]
*>
*> [TXT]
-*> \endhtmlonly
*
* Definition:
* ===========
@@ -260,7 +258,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \ingroup doubleOTHERauxiliary
+*> \ingroup laqr3
*
*> \par Contributors:
* ==================
@@ -269,9 +267,11 @@
*> University of Kansas, USA
*>
* =====================================================================
- SUBROUTINE DLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
+ SUBROUTINE DLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH,
+ $ ILOZ,
$ IHIZ, Z, LDZ, NS, ND, SR, SI, V, LDV, NH, T,
$ LDT, NV, WV, LDWV, WORK, LWORK )
+ IMPLICIT NONE
*
* -- LAPACK auxiliary routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
@@ -307,9 +307,9 @@ SUBROUTINE DLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
EXTERNAL DLAMCH, ILAENV
* ..
* .. External Subroutines ..
- EXTERNAL DCOPY, DGEHRD, DGEMM, DLABAD, DLACPY, DLAHQR,
- $ DLANV2, DLAQR4, DLARF, DLARFG, DLASET, DORMHR,
- $ DTREXC
+ EXTERNAL DCOPY, DGEHRD, DGEMM, DLACPY, DLAHQR,
+ $ DLANV2,
+ $ DLAQR4, DLARF1F, DLARFG, DLASET, DORMHR, DTREXC
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, INT, MAX, MIN, SQRT
@@ -330,13 +330,15 @@ SUBROUTINE DLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
*
* ==== Workspace query call to DORMHR ====
*
- CALL DORMHR( 'R', 'N', JW, JW, 1, JW-1, T, LDT, WORK, V, LDV,
+ CALL DORMHR( 'R', 'N', JW, JW, 1, JW-1, T, LDT, WORK, V,
+ $ LDV,
$ WORK, -1, INFO )
LWK2 = INT( WORK( 1 ) )
*
* ==== Workspace query call to DLAQR4 ====
*
- CALL DLAQR4( .true., .true., JW, 1, JW, T, LDT, SR, SI, 1, JW,
+ CALL DLAQR4( .true., .true., JW, 1, JW, T, LDT, SR, SI, 1,
+ $ JW,
$ V, LDV, WORK, -1, INFQR )
LWK3 = INT( WORK( 1 ) )
*
@@ -367,7 +369,6 @@ SUBROUTINE DLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
*
SAFMIN = DLAMCH( 'SAFE MINIMUM' )
SAFMAX = ONE / SAFMIN
- CALL DLABAD( SAFMIN, SAFMAX )
ULP = DLAMCH( 'PRECISION' )
SMLNUM = SAFMIN*( DBLE( N ) / ULP )
*
@@ -407,7 +408,8 @@ SUBROUTINE DLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
* . here and there to keep track.) ====
*
CALL DLACPY( 'U', JW, JW, H( KWTOP, KWTOP ), LDH, T, LDT )
- CALL DCOPY( JW-1, H( KWTOP+1, KWTOP ), LDH+1, T( 2, 1 ), LDT+1 )
+ CALL DCOPY( JW-1, H( KWTOP+1, KWTOP ), LDH+1, T( 2, 1 ),
+ $ LDT+1 )
*
CALL DLASET( 'A', JW, JW, ZERO, ONE, V, LDV )
NMIN = ILAENV( 12, 'DLAQR3', 'SV', JW, 1, JW, LWORK )
@@ -460,7 +462,8 @@ SUBROUTINE DLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
* . (DTREXC can not fail in this case.) ====
*
IFST = NS
- CALL DTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, WORK,
+ CALL DTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST,
+ $ WORK,
$ INFO )
ILST = ILST + 1
END IF
@@ -485,7 +488,8 @@ SUBROUTINE DLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
* . ILST in case of a rare exchange failure. ====
*
IFST = NS
- CALL DTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, WORK,
+ CALL DTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST,
+ $ WORK,
$ INFO )
ILST = ILST + 2
END IF
@@ -547,7 +551,8 @@ SUBROUTINE DLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
SORTED = .false.
IFST = I
ILST = K
- CALL DTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, WORK,
+ CALL DTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST,
+ $ WORK,
$ INFO )
IF( INFO.EQ.0 ) THEN
I = ILST
@@ -602,15 +607,15 @@ SUBROUTINE DLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
CALL DCOPY( NS, V, LDV, WORK, 1 )
BETA = WORK( 1 )
CALL DLARFG( NS, BETA, WORK( 2 ), 1, TAU )
- WORK( 1 ) = ONE
*
- CALL DLASET( 'L', JW-2, JW-2, ZERO, ZERO, T( 3, 1 ), LDT )
+ CALL DLASET( 'L', JW-2, JW-2, ZERO, ZERO, T( 3, 1 ),
+ $ LDT )
*
- CALL DLARF( 'L', NS, JW, WORK, 1, TAU, T, LDT,
+ CALL DLARF1F( 'L', NS, JW, WORK, 1, TAU, T, LDT,
$ WORK( JW+1 ) )
- CALL DLARF( 'R', NS, NS, WORK, 1, TAU, T, LDT,
+ CALL DLARF1F( 'R', NS, NS, WORK, 1, TAU, T, LDT,
$ WORK( JW+1 ) )
- CALL DLARF( 'R', JW, NS, WORK, 1, TAU, V, LDV,
+ CALL DLARF1F( 'R', JW, NS, WORK, 1, TAU, V, LDV,
$ WORK( JW+1 ) )
*
CALL DGEHRD( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ),
@@ -629,7 +634,8 @@ SUBROUTINE DLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
* . H and Z, if requested. ====
*
IF( NS.GT.1 .AND. S.NE.ZERO )
- $ CALL DORMHR( 'R', 'N', JW, NS, 1, NS, T, LDT, WORK, V, LDV,
+ $ CALL DORMHR( 'R', 'N', JW, NS, 1, NS, T, LDT, WORK, V,
+ $ LDV,
$ WORK( JW+1 ), LWORK-JW, INFO )
*
* ==== Update vertical slab in H ====
@@ -643,7 +649,8 @@ SUBROUTINE DLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
KLN = MIN( NV, KWTOP-KROW )
CALL DGEMM( 'N', 'N', KLN, JW, JW, ONE, H( KROW, KWTOP ),
$ LDH, V, LDV, ZERO, WV, LDWV )
- CALL DLACPY( 'A', KLN, JW, WV, LDWV, H( KROW, KWTOP ), LDH )
+ CALL DLACPY( 'A', KLN, JW, WV, LDWV, H( KROW, KWTOP ),
+ $ LDH )
70 CONTINUE
*
* ==== Update horizontal slab in H ====
@@ -663,7 +670,8 @@ SUBROUTINE DLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
IF( WANTZ ) THEN
DO 90 KROW = ILOZ, IHIZ, NV
KLN = MIN( NV, IHIZ-KROW+1 )
- CALL DGEMM( 'N', 'N', KLN, JW, JW, ONE, Z( KROW, KWTOP ),
+ CALL DGEMM( 'N', 'N', KLN, JW, JW, ONE, Z( KROW,
+ $ KWTOP ),
$ LDZ, V, LDV, ZERO, WV, LDWV )
CALL DLACPY( 'A', KLN, JW, WV, LDWV, Z( KROW, KWTOP ),
$ LDZ )
diff --git a/lapack-netlib/SRC/dlarf1f.c b/lapack-netlib/SRC/dlarf1f.c
new file mode 100644
index 0000000000..958a362fcb
--- /dev/null
+++ b/lapack-netlib/SRC/dlarf1f.c
@@ -0,0 +1,569 @@
+#include
+#include
+#include
+#include
+#include
+#ifdef complex
+#undef complex
+#endif
+#ifdef I
+#undef I
+#endif
+
+#if defined(_WIN64)
+typedef long long BLASLONG;
+typedef unsigned long long BLASULONG;
+#else
+typedef long BLASLONG;
+typedef unsigned long BLASULONG;
+#endif
+
+#ifdef LAPACK_ILP64
+typedef BLASLONG blasint;
+#if defined(_WIN64)
+#define blasabs(x) llabs(x)
+#else
+#define blasabs(x) labs(x)
+#endif
+#else
+typedef int blasint;
+#define blasabs(x) abs(x)
+#endif
+
+typedef blasint integer;
+
+typedef unsigned int uinteger;
+typedef char *address;
+typedef short int shortint;
+typedef float real;
+typedef double doublereal;
+typedef struct { real r, i; } complex;
+typedef struct { doublereal r, i; } doublecomplex;
+#ifdef _MSC_VER
+static inline _Fcomplex Cf(complex *z) {_Fcomplex zz={z->r , z->i}; return zz;}
+static inline _Dcomplex Cd(doublecomplex *z) {_Dcomplex zz={z->r , z->i};return zz;}
+static inline _Fcomplex * _pCf(complex *z) {return (_Fcomplex*)z;}
+static inline _Dcomplex * _pCd(doublecomplex *z) {return (_Dcomplex*)z;}
+#else
+static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;}
+static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;}
+static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;}
+static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;}
+#endif
+#define pCf(z) (*_pCf(z))
+#define pCd(z) (*_pCd(z))
+typedef int logical;
+typedef short int shortlogical;
+typedef char logical1;
+typedef char integer1;
+
+#define TRUE_ (1)
+#define FALSE_ (0)
+
+/* Extern is for use with -E */
+#ifndef Extern
+#define Extern extern
+#endif
+
+/* I/O stuff */
+
+typedef int flag;
+typedef int ftnlen;
+typedef int ftnint;
+
+/*external read, write*/
+typedef struct
+{ flag cierr;
+ ftnint ciunit;
+ flag ciend;
+ char *cifmt;
+ ftnint cirec;
+} cilist;
+
+/*internal read, write*/
+typedef struct
+{ flag icierr;
+ char *iciunit;
+ flag iciend;
+ char *icifmt;
+ ftnint icirlen;
+ ftnint icirnum;
+} icilist;
+
+/*open*/
+typedef struct
+{ flag oerr;
+ ftnint ounit;
+ char *ofnm;
+ ftnlen ofnmlen;
+ char *osta;
+ char *oacc;
+ char *ofm;
+ ftnint orl;
+ char *oblnk;
+} olist;
+
+/*close*/
+typedef struct
+{ flag cerr;
+ ftnint cunit;
+ char *csta;
+} cllist;
+
+/*rewind, backspace, endfile*/
+typedef struct
+{ flag aerr;
+ ftnint aunit;
+} alist;
+
+/* inquire */
+typedef struct
+{ flag inerr;
+ ftnint inunit;
+ char *infile;
+ ftnlen infilen;
+ ftnint *inex; /*parameters in standard's order*/
+ ftnint *inopen;
+ ftnint *innum;
+ ftnint *innamed;
+ char *inname;
+ ftnlen innamlen;
+ char *inacc;
+ ftnlen inacclen;
+ char *inseq;
+ ftnlen inseqlen;
+ char *indir;
+ ftnlen indirlen;
+ char *infmt;
+ ftnlen infmtlen;
+ char *inform;
+ ftnint informlen;
+ char *inunf;
+ ftnlen inunflen;
+ ftnint *inrecl;
+ ftnint *innrec;
+ char *inblank;
+ ftnlen inblanklen;
+} inlist;
+
+#define VOID void
+
+union Multitype { /* for multiple entry points */
+ integer1 g;
+ shortint h;
+ integer i;
+ /* longint j; */
+ real r;
+ doublereal d;
+ complex c;
+ doublecomplex z;
+ };
+
+typedef union Multitype Multitype;
+
+struct Vardesc { /* for Namelist */
+ char *name;
+ char *addr;
+ ftnlen *dims;
+ int type;
+ };
+typedef struct Vardesc Vardesc;
+
+struct Namelist {
+ char *name;
+ Vardesc **vars;
+ int nvars;
+ };
+typedef struct Namelist Namelist;
+
+#define abs(x) ((x) >= 0 ? (x) : -(x))
+#define dabs(x) (fabs(x))
+#define f2cmin(a,b) ((a) <= (b) ? (a) : (b))
+#define f2cmax(a,b) ((a) >= (b) ? (a) : (b))
+#define dmin(a,b) (f2cmin(a,b))
+#define dmax(a,b) (f2cmax(a,b))
+#define bit_test(a,b) ((a) >> (b) & 1)
+#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b)))
+#define bit_set(a,b) ((a) | ((uinteger)1 << (b)))
+
+#define abort_() { sig_die("Fortran abort routine called", 1); }
+#define c_abs(z) (cabsf(Cf(z)))
+#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); }
+#ifdef _MSC_VER
+#define c_div(c, a, b) {Cf(c)._Val[0] = (Cf(a)._Val[0]/Cf(b)._Val[0]); Cf(c)._Val[1]=(Cf(a)._Val[1]/Cf(b)._Val[1]);}
+#define z_div(c, a, b) {Cd(c)._Val[0] = (Cd(a)._Val[0]/Cd(b)._Val[0]); Cd(c)._Val[1]=(Cd(a)._Val[1]/Cd(b)._Val[1]);}
+#else
+#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);}
+#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);}
+#endif
+#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));}
+#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));}
+#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));}
+//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));}
+#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));}
+#define d_abs(x) (fabs(*(x)))
+#define d_acos(x) (acos(*(x)))
+#define d_asin(x) (asin(*(x)))
+#define d_atan(x) (atan(*(x)))
+#define d_atn2(x, y) (atan2(*(x),*(y)))
+#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); }
+#define r_cnjg(R, Z) { pCf(R) = conjf(Cf(Z)); }
+#define d_cos(x) (cos(*(x)))
+#define d_cosh(x) (cosh(*(x)))
+#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 )
+#define d_exp(x) (exp(*(x)))
+#define d_imag(z) (cimag(Cd(z)))
+#define r_imag(z) (cimagf(Cf(z)))
+#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define d_log(x) (log(*(x)))
+#define d_mod(x, y) (fmod(*(x), *(y)))
+#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x)))
+#define d_nint(x) u_nint(*(x))
+#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a)))
+#define d_sign(a,b) u_sign(*(a),*(b))
+#define r_sign(a,b) u_sign(*(a),*(b))
+#define d_sin(x) (sin(*(x)))
+#define d_sinh(x) (sinh(*(x)))
+#define d_sqrt(x) (sqrt(*(x)))
+#define d_tan(x) (tan(*(x)))
+#define d_tanh(x) (tanh(*(x)))
+#define i_abs(x) abs(*(x))
+#define i_dnnt(x) ((integer)u_nint(*(x)))
+#define i_len(s, n) (n)
+#define i_nint(x) ((integer)u_nint(*(x)))
+#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b)))
+#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; }
+#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d))))
+#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
+#define sig_die(s, kill) { exit(1); }
+#define s_stop(s, n) {exit(0);}
+#define z_abs(z) (cabs(Cd(z)))
+#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
+#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
+
+/* procedure parameter types for -A and -C++ */
+
+#define F2C_proc_par_types 1
+#ifdef __cplusplus
+typedef logical (*L_fp)(...);
+#else
+typedef logical (*L_fp)();
+#endif
+
+/* Table of constant values */
+
+static doublereal c_b4 = 1.;
+static doublereal c_b5 = 0.;
+static integer c__1 = 1;
+
+/* > \brief \b DLARF1F applies an elementary reflector to a general rectangular */
+/* matrix assuming v(1) = 1. */
+
+/* =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/* http://www.netlib.org/lapack/explore-html/ */
+
+/* > Download DLARF1F + dependencies */
+/* > */
+/* > [TGZ] */
+/* > */
+/* > [ZIP] */
+/* > */
+/* > [TXT] */
+
+/* Definition: */
+/* =========== */
+
+/* SUBROUTINE DLARF1F( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) */
+
+/* CHARACTER SIDE */
+/* INTEGER INCV, LDC, M, N */
+/* DOUBLE PRECISION TAU */
+/* DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * ) */
+
+
+/* > \par Purpose: */
+/* ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > DLARF1F applies a real elementary reflector H to a real m by n matrix */
+/* > C, from either the left or the right. H is represented in the form */
+/* > */
+/* > H = I - tau * v * v**T */
+/* > */
+/* > where tau is a real scalar and v is a real vector. */
+/* > */
+/* > If tau = 0, then H is taken to be the unit matrix. */
+/* > \endverbatim */
+
+/* Arguments: */
+/* ========== */
+
+/* > \param[in] SIDE */
+/* > \verbatim */
+/* > SIDE is CHARACTER*1 */
+/* > = 'L': form H * C */
+/* > = 'R': form C * H */
+/* > \endverbatim */
+/* > */
+/* > \param[in] M */
+/* > \verbatim */
+/* > M is INTEGER */
+/* > The number of rows of the matrix C. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] N */
+/* > \verbatim */
+/* > N is INTEGER */
+/* > The number of columns of the matrix C. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] V */
+/* > \verbatim */
+/* > V is DOUBLE PRECISION array, dimension */
+/* > (1 + (M-1)*abs(INCV)) if SIDE = 'L' */
+/* > or (1 + (N-1)*abs(INCV)) if SIDE = 'R' */
+/* > The vector v in the representation of H. V is not used if */
+/* > TAU = 0. V(1) is not referenced or modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] INCV */
+/* > \verbatim */
+/* > INCV is INTEGER */
+/* > The increment between elements of v. INCV <> 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] TAU */
+/* > \verbatim */
+/* > TAU is DOUBLE PRECISION */
+/* > The value tau in the representation of H. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] C */
+/* > \verbatim */
+/* > C is DOUBLE PRECISION array, dimension (LDC,N) */
+/* > On entry, the m by n matrix C. */
+/* > On exit, C is overwritten by the matrix H * C if SIDE = 'L', */
+/* > or C * H if SIDE = 'R'. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDC */
+/* > \verbatim */
+/* > LDC is INTEGER */
+/* > The leading dimension of the array C. LDC >= f2cmax(1,M). */
+/* > \endverbatim */
+/* > */
+/* > \param[out] WORK */
+/* > \verbatim */
+/* > WORK is DOUBLE PRECISION array, dimension */
+/* > (N) if SIDE = 'L' */
+/* > or (M) if SIDE = 'R' */
+/* > \endverbatim */
+
+/* To take advantage of the fact that v(1) = 1, we do the following */
+/* v = [ 1 v_2 ]**T */
+/* If SIDE='L' */
+/* |-----| */
+/* | C_1 | */
+/* C =| C_2 | */
+/* |-----| */
+/* C_1\in\mathbb{R}^{1\times n}, C_2\in\mathbb{R}^{m-1\times n} */
+/* So we compute: */
+/* C = HC = (I - \tau vv**T)C */
+/* = C - \tau vv**T C */
+/* w = C**T v = [ C_1**T C_2**T ] [ 1 v_2 ]**T */
+/* = C_1**T + C_2**T v ( DGEMM then DAXPY ) */
+/* C = C - \tau vv**T C */
+/* = C - \tau vw**T */
+/* Giving us C_1 = C_1 - \tau w**T ( DAXPY ) */
+/* and */
+/* C_2 = C_2 - \tau v_2w**T ( DGER ) */
+/* If SIDE='R' */
+
+/* C = [ C_1 C_2 ] */
+/* C_1\in\mathbb{R}^{m\times 1}, C_2\in\mathbb{R}^{m\times n-1} */
+/* So we compute: */
+/* C = CH = C(I - \tau vv**T) */
+/* = C - \tau Cvv**T */
+
+/* w = Cv = [ C_1 C_2 ] [ 1 v_2 ]**T */
+/* = C_1 + C_2v_2 ( DGEMM then DAXPY ) */
+/* C = C - \tau Cvv**T */
+/* = C - \tau wv**T */
+/* Giving us C_1 = C_1 - \tau w ( DAXPY ) */
+/* and */
+/* C_2 = C_2 - \tau wv_2**T ( DGER ) */
+
+/* Authors: */
+/* ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \ingroup larf */
+
+/* ===================================================================== */
+/* Subroutine */ int dlarf1f_(char *side, integer *m, integer *n, doublereal *
+ v, integer *incv, doublereal *tau, doublereal *c__, integer *ldc,
+ doublereal *work)
+{
+ /* System generated locals */
+ integer c_dim1, c_offset, i__1;
+ doublereal d__1;
+
+ /* Local variables */
+ integer i__;
+ logical applyleft;
+ extern /* Subroutine */ int dger_(integer *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *), dscal_(integer *, doublereal *, doublereal *, integer
+ *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int dgemv_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *);
+ integer lastc;
+ extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *);
+ integer lastv;
+ extern integer iladlc_(integer *, integer *, doublereal *, integer *),
+ iladlr_(integer *, integer *, doublereal *, integer *);
+
+
+/* -- LAPACK auxiliary routine -- */
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+
+
+/* ===================================================================== */
+
+
+ /* Parameter adjustments */
+ --v;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --work;
+
+ /* Function Body */
+ applyleft = lsame_(side, "L");
+ lastv = 1;
+ lastc = 0;
+ if (*tau != 0.) {
+/* Set up variables for scanning V. LASTV begins pointing to the end */
+/* of V. */
+ if (applyleft) {
+ lastv = *m;
+ } else {
+ lastv = *n;
+ }
+ if (*incv > 0) {
+ i__ = (lastv - 1) * *incv + 1;
+ } else {
+ i__ = 1;
+ }
+/* Look for the last non-zero row in V. */
+/* Since we are assuming that V(1) = 1, and it is not stored, so we */
+/* shouldn't access it. */
+ while(lastv > 1 && v[i__] == 0.) {
+ --lastv;
+ i__ -= *incv;
+ }
+ if (applyleft) {
+/* Scan for the last non-zero column in C(1:lastv,:). */
+ lastc = iladlc_(&lastv, n, &c__[c_offset], ldc);
+ } else {
+/* Scan for the last non-zero row in C(:,1:lastv). */
+ lastc = iladlr_(m, &lastv, &c__[c_offset], ldc);
+ }
+ }
+ if (lastc == 0) {
+ return 0;
+ }
+ if (applyleft) {
+
+/* Form H * C */
+
+/* Check if lastv = 1. This means v = 1, So we just need to comp */
+/* C := HC = (1-\tau)C. */
+ if (lastv == 1) {
+
+/* C(1,1:lastc) := ( 1 - tau ) * C(1,1:lastc) */
+
+ d__1 = 1. - *tau;
+ dscal_(&lastc, &d__1, &c__[c_offset], ldc);
+ } else {
+
+/* w(1:lastc,1) := C(1:lastv,1:lastc)**T * v(1:lastv,1) */
+
+/* w(1:lastc,1) := C(2:lastv,1:lastc)**T * v(2:lastv,1) */
+ i__1 = lastv - 1;
+ dgemv_("Transpose", &i__1, &lastc, &c_b4, &c__[c_dim1 + 2], ldc, &
+ v[*incv + 1], incv, &c_b5, &work[1], &c__1);
+/* w(1:lastc,1) += C(1,1:lastc)**T * v(1,1) = C(1,1:lastc)**T */
+ daxpy_(&lastc, &c_b4, &c__[c_offset], ldc, &work[1], &c__1);
+
+/* C(1:lastv,1:lastc) := C(...) - tau * v(1:lastv,1) * w(1:lastc,1)**T */
+
+/* C(1, 1:lastc) := C(...) - tau * v(1,1) * w(1:lastc,1)**T */
+/* = C(...) - tau * w(1:lastc,1)**T */
+ d__1 = -(*tau);
+ daxpy_(&lastc, &d__1, &work[1], &c__1, &c__[c_offset], ldc);
+/* C(2:lastv,1:lastc) := C(...) - tau * v(2:lastv,1)*w(1:last */
+ i__1 = lastv - 1;
+ d__1 = -(*tau);
+ dger_(&i__1, &lastc, &d__1, &v[*incv + 1], incv, &work[1], &c__1,
+ &c__[c_dim1 + 2], ldc);
+ }
+ } else {
+
+/* Form C * H */
+
+/* Check if n = 1. This means v = 1, so we just need to compute */
+/* C := CH = C(1-\tau). */
+ if (lastv == 1) {
+
+/* C(1:lastc,1) := ( 1 - tau ) * C(1:lastc,1) */
+
+ d__1 = 1. - *tau;
+ dscal_(&lastc, &d__1, &c__[c_offset], &c__1);
+ } else {
+
+/* w(1:lastc,1) := C(1:lastc,1:lastv) * v(1:lastv,1) */
+
+/* w(1:lastc,1) := C(1:lastc,2:lastv) * v(2:lastv,1) */
+ i__1 = lastv - 1;
+ dgemv_("No transpose", &lastc, &i__1, &c_b4, &c__[(c_dim1 << 1) +
+ 1], ldc, &v[*incv + 1], incv, &c_b5, &work[1], &c__1);
+/* w(1:lastc,1) += C(1:lastc,1) v(1,1) = C(1:lastc,1) */
+ daxpy_(&lastc, &c_b4, &c__[c_offset], &c__1, &work[1], &c__1);
+
+/* C(1:lastc,1:lastv) := C(...) - tau * w(1:lastc,1) * v(1:lastv,1)**T */
+
+/* C(1:lastc,1) := C(...) - tau * w(1:lastc,1) * v(1,1)** */
+/* = C(...) - tau * w(1:lastc,1) */
+ d__1 = -(*tau);
+ daxpy_(&lastc, &d__1, &work[1], &c__1, &c__[c_offset], &c__1);
+/* C(1:lastc,2:lastv) := C(...) - tau * w(1:lastc,1) * v(2:la */
+ i__1 = lastv - 1;
+ d__1 = -(*tau);
+ dger_(&lastc, &i__1, &d__1, &work[1], &c__1, &v[*incv + 1], incv,
+ &c__[(c_dim1 << 1) + 1], ldc);
+ }
+ }
+ return 0;
+
+/* End of DLARF1F */
+
+} /* dlarf1f_ */
+
diff --git a/lapack-netlib/SRC/dlarf1f.f b/lapack-netlib/SRC/dlarf1f.f
new file mode 100644
index 0000000000..c65035c61f
--- /dev/null
+++ b/lapack-netlib/SRC/dlarf1f.f
@@ -0,0 +1,291 @@
+*> \brief \b DLARF1F applies an elementary reflector to a general rectangular
+* matrix assuming v(1) = 1.
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> Download DLARF1F + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE DLARF1F( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )
+*
+* .. Scalar Arguments ..
+* CHARACTER SIDE
+* INTEGER INCV, LDC, M, N
+* DOUBLE PRECISION TAU
+* ..
+* .. Array Arguments ..
+* DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> DLARF1F applies a real elementary reflector H to a real m by n matrix
+*> C, from either the left or the right. H is represented in the form
+*>
+*> H = I - tau * v * v**T
+*>
+*> where tau is a real scalar and v is a real vector.
+*>
+*> If tau = 0, then H is taken to be the unit matrix.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] SIDE
+*> \verbatim
+*> SIDE is CHARACTER*1
+*> = 'L': form H * C
+*> = 'R': form C * H
+*> \endverbatim
+*>
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows of the matrix C.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of columns of the matrix C.
+*> \endverbatim
+*>
+*> \param[in] V
+*> \verbatim
+*> V is DOUBLE PRECISION array, dimension
+*> (1 + (M-1)*abs(INCV)) if SIDE = 'L'
+*> or (1 + (N-1)*abs(INCV)) if SIDE = 'R'
+*> The vector v in the representation of H. V is not used if
+*> TAU = 0. V(1) is not referenced or modified.
+*> \endverbatim
+*>
+*> \param[in] INCV
+*> \verbatim
+*> INCV is INTEGER
+*> The increment between elements of v. INCV <> 0.
+*> \endverbatim
+*>
+*> \param[in] TAU
+*> \verbatim
+*> TAU is DOUBLE PRECISION
+*> The value tau in the representation of H.
+*> \endverbatim
+*>
+*> \param[in,out] C
+*> \verbatim
+*> C is DOUBLE PRECISION array, dimension (LDC,N)
+*> On entry, the m by n matrix C.
+*> On exit, C is overwritten by the matrix H * C if SIDE = 'L',
+*> or C * H if SIDE = 'R'.
+*> \endverbatim
+*>
+*> \param[in] LDC
+*> \verbatim
+*> LDC is INTEGER
+*> The leading dimension of the array C. LDC >= max(1,M).
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is DOUBLE PRECISION array, dimension
+*> (N) if SIDE = 'L'
+*> or (M) if SIDE = 'R'
+*> \endverbatim
+*
+* To take advantage of the fact that v(1) = 1, we do the following
+* v = [ 1 v_2 ]**T
+* If SIDE='L'
+* |-----|
+* | C_1 |
+* C =| C_2 |
+* |-----|
+* C_1\in\mathbb{R}^{1\times n}, C_2\in\mathbb{R}^{m-1\times n}
+* So we compute:
+* C = HC = (I - \tau vv**T)C
+* = C - \tau vv**T C
+* w = C**T v = [ C_1**T C_2**T ] [ 1 v_2 ]**T
+* = C_1**T + C_2**T v ( DGEMM then DAXPY )
+* C = C - \tau vv**T C
+* = C - \tau vw**T
+* Giving us C_1 = C_1 - \tau w**T ( DAXPY )
+* and
+* C_2 = C_2 - \tau v_2w**T ( DGER )
+* If SIDE='R'
+*
+* C = [ C_1 C_2 ]
+* C_1\in\mathbb{R}^{m\times 1}, C_2\in\mathbb{R}^{m\times n-1}
+* So we compute:
+* C = CH = C(I - \tau vv**T)
+* = C - \tau Cvv**T
+*
+* w = Cv = [ C_1 C_2 ] [ 1 v_2 ]**T
+* = C_1 + C_2v_2 ( DGEMM then DAXPY )
+* C = C - \tau Cvv**T
+* = C - \tau wv**T
+* Giving us C_1 = C_1 - \tau w ( DAXPY )
+* and
+* C_2 = C_2 - \tau wv_2**T ( DGER )
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \ingroup larf
+*
+* =====================================================================
+ SUBROUTINE DLARF1F( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )
+ IMPLICIT NONE
+*
+* -- LAPACK auxiliary routine --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+*
+* .. Scalar Arguments ..
+ CHARACTER SIDE
+ INTEGER INCV, LDC, M, N
+ DOUBLE PRECISION TAU
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE, ZERO
+ PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL APPLYLEFT
+ INTEGER I, LASTV, LASTC
+* ..
+* .. External Subroutines ..
+ EXTERNAL DGEMV, DGER, DAXPY, DSCAL
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILADLR, ILADLC
+ EXTERNAL LSAME, ILADLR, ILADLC
+* ..
+* .. Executable Statements ..
+*
+ APPLYLEFT = LSAME( SIDE, 'L' )
+ LASTV = 1
+ LASTC = 0
+ IF( TAU.NE.ZERO ) THEN
+! Set up variables for scanning V. LASTV begins pointing to the end
+! of V.
+ IF( APPLYLEFT ) THEN
+ LASTV = M
+ ELSE
+ LASTV = N
+ END IF
+ IF( INCV.GT.0 ) THEN
+ I = 1 + (LASTV-1) * INCV
+ ELSE
+ I = 1
+ END IF
+! Look for the last non-zero row in V.
+! Since we are assuming that V(1) = 1, and it is not stored, so we
+! shouldn't access it.
+ DO WHILE( LASTV.GT.1 .AND. V( I ).EQ.ZERO )
+ LASTV = LASTV - 1
+ I = I - INCV
+ END DO
+ IF( APPLYLEFT ) THEN
+! Scan for the last non-zero column in C(1:lastv,:).
+ LASTC = ILADLC(LASTV, N, C, LDC)
+ ELSE
+! Scan for the last non-zero row in C(:,1:lastv).
+ LASTC = ILADLR(M, LASTV, C, LDC)
+ END IF
+ END IF
+ IF( LASTC.EQ.0 ) THEN
+ RETURN
+ END IF
+ IF( APPLYLEFT ) THEN
+*
+* Form H * C
+*
+ ! Check if lastv = 1. This means v = 1, So we just need to compute
+ ! C := HC = (1-\tau)C.
+ IF( LASTV.EQ.1 ) THEN
+*
+* C(1,1:lastc) := ( 1 - tau ) * C(1,1:lastc)
+*
+ CALL DSCAL(LASTC, ONE - TAU, C, LDC)
+ ELSE
+*
+* w(1:lastc,1) := C(1:lastv,1:lastc)**T * v(1:lastv,1)
+*
+ ! w(1:lastc,1) := C(2:lastv,1:lastc)**T * v(2:lastv,1)
+ CALL DGEMV( 'Transpose', LASTV-1, LASTC, ONE, C(1+1,1),
+ $ LDC, V(1+INCV), INCV, ZERO, WORK, 1)
+ ! w(1:lastc,1) += C(1,1:lastc)**T * v(1,1) = C(1,1:lastc)**T
+ CALL DAXPY(LASTC, ONE, C, LDC, WORK, 1)
+*
+* C(1:lastv,1:lastc) := C(...) - tau * v(1:lastv,1) * w(1:lastc,1)**T
+*
+ ! C(1, 1:lastc) := C(...) - tau * v(1,1) * w(1:lastc,1)**T
+ ! = C(...) - tau * w(1:lastc,1)**T
+ CALL DAXPY(LASTC, -TAU, WORK, 1, C, LDC)
+ ! C(2:lastv,1:lastc) := C(...) - tau * v(2:lastv,1)*w(1:lastc,1)**T
+ CALL DGER(LASTV-1, LASTC, -TAU, V(1+INCV), INCV, WORK, 1,
+ $ C(1+1,1), LDC)
+ END IF
+ ELSE
+*
+* Form C * H
+*
+ ! Check if n = 1. This means v = 1, so we just need to compute
+ ! C := CH = C(1-\tau).
+ IF( LASTV.EQ.1 ) THEN
+*
+* C(1:lastc,1) := ( 1 - tau ) * C(1:lastc,1)
+*
+ CALL DSCAL(LASTC, ONE - TAU, C, 1)
+ ELSE
+*
+* w(1:lastc,1) := C(1:lastc,1:lastv) * v(1:lastv,1)
+*
+ ! w(1:lastc,1) := C(1:lastc,2:lastv) * v(2:lastv,1)
+ CALL DGEMV( 'No transpose', LASTC, LASTV-1, ONE,
+ $ C(1,1+1), LDC, V(1+INCV), INCV, ZERO, WORK, 1 )
+ ! w(1:lastc,1) += C(1:lastc,1) v(1,1) = C(1:lastc,1)
+ CALL DAXPY(LASTC, ONE, C, 1, WORK, 1)
+*
+* C(1:lastc,1:lastv) := C(...) - tau * w(1:lastc,1) * v(1:lastv,1)**T
+*
+ ! C(1:lastc,1) := C(...) - tau * w(1:lastc,1) * v(1,1)**T
+ ! = C(...) - tau * w(1:lastc,1)
+ CALL DAXPY(LASTC, -TAU, WORK, 1, C, 1)
+ ! C(1:lastc,2:lastv) := C(...) - tau * w(1:lastc,1) * v(2:lastv)**T
+ CALL DGER( LASTC, LASTV-1, -TAU, WORK, 1, V(1+INCV),
+ $ INCV, C(1,1+1), LDC )
+ END IF
+ END IF
+ RETURN
+*
+* End of DLARF1F
+*
+ END
diff --git a/lapack-netlib/SRC/dlarf1l.c b/lapack-netlib/SRC/dlarf1l.c
new file mode 100644
index 0000000000..aa951e935c
--- /dev/null
+++ b/lapack-netlib/SRC/dlarf1l.c
@@ -0,0 +1,534 @@
+#include
+#include
+#include
+#include
+#include
+#ifdef complex
+#undef complex
+#endif
+#ifdef I
+#undef I
+#endif
+
+#if defined(_WIN64)
+typedef long long BLASLONG;
+typedef unsigned long long BLASULONG;
+#else
+typedef long BLASLONG;
+typedef unsigned long BLASULONG;
+#endif
+
+#ifdef LAPACK_ILP64
+typedef BLASLONG blasint;
+#if defined(_WIN64)
+#define blasabs(x) llabs(x)
+#else
+#define blasabs(x) labs(x)
+#endif
+#else
+typedef int blasint;
+#define blasabs(x) abs(x)
+#endif
+
+typedef blasint integer;
+
+typedef unsigned int uinteger;
+typedef char *address;
+typedef short int shortint;
+typedef float real;
+typedef double doublereal;
+typedef struct { real r, i; } complex;
+typedef struct { doublereal r, i; } doublecomplex;
+#ifdef _MSC_VER
+static inline _Fcomplex Cf(complex *z) {_Fcomplex zz={z->r , z->i}; return zz;}
+static inline _Dcomplex Cd(doublecomplex *z) {_Dcomplex zz={z->r , z->i};return zz;}
+static inline _Fcomplex * _pCf(complex *z) {return (_Fcomplex*)z;}
+static inline _Dcomplex * _pCd(doublecomplex *z) {return (_Dcomplex*)z;}
+#else
+static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;}
+static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;}
+static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;}
+static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;}
+#endif
+#define pCf(z) (*_pCf(z))
+#define pCd(z) (*_pCd(z))
+typedef int logical;
+typedef short int shortlogical;
+typedef char logical1;
+typedef char integer1;
+
+#define TRUE_ (1)
+#define FALSE_ (0)
+
+/* Extern is for use with -E */
+#ifndef Extern
+#define Extern extern
+#endif
+
+/* I/O stuff */
+
+typedef int flag;
+typedef int ftnlen;
+typedef int ftnint;
+
+/*external read, write*/
+typedef struct
+{ flag cierr;
+ ftnint ciunit;
+ flag ciend;
+ char *cifmt;
+ ftnint cirec;
+} cilist;
+
+/*internal read, write*/
+typedef struct
+{ flag icierr;
+ char *iciunit;
+ flag iciend;
+ char *icifmt;
+ ftnint icirlen;
+ ftnint icirnum;
+} icilist;
+
+/*open*/
+typedef struct
+{ flag oerr;
+ ftnint ounit;
+ char *ofnm;
+ ftnlen ofnmlen;
+ char *osta;
+ char *oacc;
+ char *ofm;
+ ftnint orl;
+ char *oblnk;
+} olist;
+
+/*close*/
+typedef struct
+{ flag cerr;
+ ftnint cunit;
+ char *csta;
+} cllist;
+
+/*rewind, backspace, endfile*/
+typedef struct
+{ flag aerr;
+ ftnint aunit;
+} alist;
+
+/* inquire */
+typedef struct
+{ flag inerr;
+ ftnint inunit;
+ char *infile;
+ ftnlen infilen;
+ ftnint *inex; /*parameters in standard's order*/
+ ftnint *inopen;
+ ftnint *innum;
+ ftnint *innamed;
+ char *inname;
+ ftnlen innamlen;
+ char *inacc;
+ ftnlen inacclen;
+ char *inseq;
+ ftnlen inseqlen;
+ char *indir;
+ ftnlen indirlen;
+ char *infmt;
+ ftnlen infmtlen;
+ char *inform;
+ ftnint informlen;
+ char *inunf;
+ ftnlen inunflen;
+ ftnint *inrecl;
+ ftnint *innrec;
+ char *inblank;
+ ftnlen inblanklen;
+} inlist;
+
+#define VOID void
+
+union Multitype { /* for multiple entry points */
+ integer1 g;
+ shortint h;
+ integer i;
+ /* longint j; */
+ real r;
+ doublereal d;
+ complex c;
+ doublecomplex z;
+ };
+
+typedef union Multitype Multitype;
+
+struct Vardesc { /* for Namelist */
+ char *name;
+ char *addr;
+ ftnlen *dims;
+ int type;
+ };
+typedef struct Vardesc Vardesc;
+
+struct Namelist {
+ char *name;
+ Vardesc **vars;
+ int nvars;
+ };
+typedef struct Namelist Namelist;
+
+#define abs(x) ((x) >= 0 ? (x) : -(x))
+#define dabs(x) (fabs(x))
+#define f2cmin(a,b) ((a) <= (b) ? (a) : (b))
+#define f2cmax(a,b) ((a) >= (b) ? (a) : (b))
+#define dmin(a,b) (f2cmin(a,b))
+#define dmax(a,b) (f2cmax(a,b))
+#define bit_test(a,b) ((a) >> (b) & 1)
+#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b)))
+#define bit_set(a,b) ((a) | ((uinteger)1 << (b)))
+
+#define abort_() { sig_die("Fortran abort routine called", 1); }
+#define c_abs(z) (cabsf(Cf(z)))
+#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); }
+#ifdef _MSC_VER
+#define c_div(c, a, b) {Cf(c)._Val[0] = (Cf(a)._Val[0]/Cf(b)._Val[0]); Cf(c)._Val[1]=(Cf(a)._Val[1]/Cf(b)._Val[1]);}
+#define z_div(c, a, b) {Cd(c)._Val[0] = (Cd(a)._Val[0]/Cd(b)._Val[0]); Cd(c)._Val[1]=(Cd(a)._Val[1]/Cd(b)._Val[1]);}
+#else
+#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);}
+#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);}
+#endif
+#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));}
+#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));}
+#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));}
+//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));}
+#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));}
+#define d_abs(x) (fabs(*(x)))
+#define d_acos(x) (acos(*(x)))
+#define d_asin(x) (asin(*(x)))
+#define d_atan(x) (atan(*(x)))
+#define d_atn2(x, y) (atan2(*(x),*(y)))
+#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); }
+#define r_cnjg(R, Z) { pCf(R) = conjf(Cf(Z)); }
+#define d_cos(x) (cos(*(x)))
+#define d_cosh(x) (cosh(*(x)))
+#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 )
+#define d_exp(x) (exp(*(x)))
+#define d_imag(z) (cimag(Cd(z)))
+#define r_imag(z) (cimagf(Cf(z)))
+#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define d_log(x) (log(*(x)))
+#define d_mod(x, y) (fmod(*(x), *(y)))
+#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x)))
+#define d_nint(x) u_nint(*(x))
+#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a)))
+#define d_sign(a,b) u_sign(*(a),*(b))
+#define r_sign(a,b) u_sign(*(a),*(b))
+#define d_sin(x) (sin(*(x)))
+#define d_sinh(x) (sinh(*(x)))
+#define d_sqrt(x) (sqrt(*(x)))
+#define d_tan(x) (tan(*(x)))
+#define d_tanh(x) (tanh(*(x)))
+#define i_abs(x) abs(*(x))
+#define i_dnnt(x) ((integer)u_nint(*(x)))
+#define i_len(s, n) (n)
+#define i_nint(x) ((integer)u_nint(*(x)))
+#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b)))
+#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; }
+#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d))))
+#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
+#define sig_die(s, kill) { exit(1); }
+#define s_stop(s, n) {exit(0);}
+#define z_abs(z) (cabs(Cd(z)))
+#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
+#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
+
+/* procedure parameter types for -A and -C++ */
+
+#define F2C_proc_par_types 1
+#ifdef __cplusplus
+typedef logical (*L_fp)(...);
+#else
+typedef logical (*L_fp)();
+#endif
+
+/* Table of constant values */
+
+static doublereal c_b4 = 1.;
+static doublereal c_b5 = 0.;
+static integer c__1 = 1;
+
+/* > \brief \b DLARF1L applies an elementary reflector to a general rectangular */
+/* matrix assuming v(lastv) = 1 where lastv is the last non-zero */
+/* element */
+
+/* =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/* http://www.netlib.org/lapack/explore-html/ */
+
+/* > Download DLARF1L + dependencies */
+/* > */
+/* > [TGZ] */
+/* > */
+/* > [ZIP] */
+/* > */
+/* > [TXT] */
+
+/* Definition: */
+/* =========== */
+
+/* SUBROUTINE DLARF1L( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) */
+
+/* CHARACTER SIDE */
+/* INTEGER INCV, LDC, M, N */
+/* DOUBLE PRECISION TAU */
+/* DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * ) */
+
+
+/* > \par Purpose: */
+/* ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > DLARF1L applies a real elementary reflector H to a real m by n matrix */
+/* > C, from either the left or the right. H is represented in the form */
+/* > */
+/* > H = I - tau * v * v**T */
+/* > */
+/* > where tau is a real scalar and v is a real vector. */
+/* > */
+/* > If tau = 0, then H is taken to be the unit matrix. */
+/* > \endverbatim */
+
+/* Arguments: */
+/* ========== */
+
+/* > \param[in] SIDE */
+/* > \verbatim */
+/* > SIDE is CHARACTER*1 */
+/* > = 'L': form H * C */
+/* > = 'R': form C * H */
+/* > \endverbatim */
+/* > */
+/* > \param[in] M */
+/* > \verbatim */
+/* > M is INTEGER */
+/* > The number of rows of the matrix C. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] N */
+/* > \verbatim */
+/* > N is INTEGER */
+/* > The number of columns of the matrix C. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] V */
+/* > \verbatim */
+/* > V is DOUBLE PRECISION array, dimension */
+/* > (1 + (M-1)*abs(INCV)) if SIDE = 'L' */
+/* > or (1 + (N-1)*abs(INCV)) if SIDE = 'R' */
+/* > The vector v in the representation of H. V is not used if */
+/* > TAU = 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] INCV */
+/* > \verbatim */
+/* > INCV is INTEGER */
+/* > The increment between elements of v. INCV <> 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] TAU */
+/* > \verbatim */
+/* > TAU is DOUBLE PRECISION */
+/* > The value tau in the representation of H. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] C */
+/* > \verbatim */
+/* > C is DOUBLE PRECISION array, dimension (LDC,N) */
+/* > On entry, the m by n matrix C. */
+/* > On exit, C is overwritten by the matrix H * C if SIDE = 'L', */
+/* > or C * H if SIDE = 'R'. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDC */
+/* > \verbatim */
+/* > LDC is INTEGER */
+/* > The leading dimension of the array C. LDC >= f2cmax(1,M). */
+/* > \endverbatim */
+/* > */
+/* > \param[out] WORK */
+/* > \verbatim */
+/* > WORK is DOUBLE PRECISION array, dimension */
+/* > (N) if SIDE = 'L' */
+/* > or (M) if SIDE = 'R' */
+/* > \endverbatim */
+
+/* Authors: */
+/* ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \ingroup larf */
+
+/* ===================================================================== */
+/* Subroutine */ int dlarf1l_(char *side, integer *m, integer *n, doublereal *
+ v, integer *incv, doublereal *tau, doublereal *c__, integer *ldc,
+ doublereal *work)
+{
+ /* System generated locals */
+ integer c_dim1, c_offset, i__1;
+ doublereal d__1;
+
+ /* Local variables */
+ integer i__;
+ logical applyleft;
+ extern /* Subroutine */ int dger_(integer *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *), dscal_(integer *, doublereal *, doublereal *, integer
+ *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int dgemv_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *);
+ integer lastc;
+ extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *);
+ integer lastv;
+ extern integer iladlc_(integer *, integer *, doublereal *, integer *),
+ iladlr_(integer *, integer *, doublereal *, integer *);
+ integer firstv;
+
+
+/* -- LAPACK auxiliary routine -- */
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+
+
+/* ===================================================================== */
+
+
+ /* Parameter adjustments */
+ --v;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --work;
+
+ /* Function Body */
+ applyleft = lsame_(side, "L");
+ firstv = 1;
+ lastc = 0;
+ if (*tau != 0.) {
+/* Set up variables for scanning V. LASTV begins pointing to the end */
+/* of V. */
+ if (applyleft) {
+ lastv = *m;
+ } else {
+ lastv = *n;
+ }
+ i__ = 1;
+/* Look for the last non-zero row in V. */
+ while(lastv > firstv && v[i__] == 0.) {
+ ++firstv;
+ i__ += *incv;
+ }
+ if (applyleft) {
+/* Scan for the last non-zero column in C(1:lastv,:). */
+ lastc = iladlc_(&lastv, n, &c__[c_offset], ldc);
+ } else {
+/* Scan for the last non-zero row in C(:,1:lastv). */
+ lastc = iladlr_(m, &lastv, &c__[c_offset], ldc);
+ }
+ }
+ if (lastc == 0) {
+ return 0;
+ }
+ if (applyleft) {
+
+/* Form H * C */
+
+ if (lastv > 0) {
+/* Check if m = 1. This means v = 1, So we just need to compu */
+/* C := HC = (1-\tau)C. */
+ if (lastv == firstv) {
+ d__1 = 1. - *tau;
+ dscal_(&lastc, &d__1, &c__[firstv + c_dim1], ldc);
+ } else {
+
+/* w(1:lastc,1) := C(1:lastv,1:lastc)**T * v(1:lastv,1) */
+
+/* w(1:lastc,1) := C(1:lastv-1,1:lastc)**T * v(1:lastv-1,1 */
+ i__1 = lastv - firstv;
+ dgemv_("Transpose", &i__1, &lastc, &c_b4, &c__[firstv +
+ c_dim1], ldc, &v[i__], incv, &c_b5, &work[1], &c__1);
+/* w(1:lastc,1) += C(lastv,1:lastc)**T * v(lastv,1) = C(la */
+ daxpy_(&lastc, &c_b4, &c__[lastv + c_dim1], ldc, &work[1], &
+ c__1);
+
+/* C(1:lastv,1:lastc) := C(...) - tau * v(1:lastv,1) * w(1:lastc,1)**T */
+
+/* C(lastv, 1:lastc) := C(...) - tau * v(lastv,1) * w(1: */
+/* = C(...) - tau * w(1:lastc,1)**T */
+ d__1 = -(*tau);
+ daxpy_(&lastc, &d__1, &work[1], &c__1, &c__[lastv + c_dim1],
+ ldc);
+/* C(1:lastv-1,1:lastc) := C(...) - tau * v(1:lastv-1,1)*w */
+ i__1 = lastv - firstv;
+ d__1 = -(*tau);
+ dger_(&i__1, &lastc, &d__1, &v[i__], incv, &work[1], &c__1, &
+ c__[firstv + c_dim1], ldc);
+ }
+ }
+ } else {
+
+/* Form C * H */
+
+ if (lastv > 0) {
+/* Check if n = 1. This means v = 1, so we just need to compu */
+/* C := CH = C(1-\tau). */
+ if (lastv == firstv) {
+ d__1 = 1. - *tau;
+ dscal_(&lastc, &d__1, &c__[c_offset], &c__1);
+ } else {
+
+/* w(1:lastc,1) := C(1:lastc,1:lastv) * v(1:lastv,1) */
+
+/* w(1:lastc,1) := C(1:lastc,1:lastv-1) * v(1:lastv-1,1) */
+ i__1 = lastv - firstv;
+ dgemv_("No transpose", &lastc, &i__1, &c_b4, &c__[firstv *
+ c_dim1 + 1], ldc, &v[i__], incv, &c_b5, &work[1], &
+ c__1);
+/* w(1:lastc,1) += C(1:lastc,lastv) * v(lastv,1) = C(1:las */
+ daxpy_(&lastc, &c_b4, &c__[lastv * c_dim1 + 1], &c__1, &work[
+ 1], &c__1);
+
+/* C(1:lastc,1:lastv) := C(...) - tau * w(1:lastc,1) * v(1:lastv,1)**T */
+
+/* C(1:lastc,lastv) := C(...) - tau * w(1:lastc,1) * v */
+/* = C(...) - tau * w(1:lastc,1) */
+ d__1 = -(*tau);
+ daxpy_(&lastc, &d__1, &work[1], &c__1, &c__[lastv * c_dim1 +
+ 1], &c__1);
+/* C(1:lastc,1:lastv-1) := C(...) - tau * w(1:lastc,1) * v */
+ i__1 = lastv - firstv;
+ d__1 = -(*tau);
+ dger_(&lastc, &i__1, &d__1, &work[1], &c__1, &v[i__], incv, &
+ c__[firstv * c_dim1 + 1], ldc);
+ }
+ }
+ }
+ return 0;
+
+/* End of DLARF1L */
+
+} /* dlarf1l_ */
+
diff --git a/lapack-netlib/SRC/dlarf1l.f b/lapack-netlib/SRC/dlarf1l.f
new file mode 100644
index 0000000000..d225701fcd
--- /dev/null
+++ b/lapack-netlib/SRC/dlarf1l.f
@@ -0,0 +1,251 @@
+*> \brief \b DLARF1L applies an elementary reflector to a general rectangular
+* matrix assuming v(lastv) = 1 where lastv is the last non-zero
+* element
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> Download DLARF1L + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE DLARF1L( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )
+*
+* .. Scalar Arguments ..
+* CHARACTER SIDE
+* INTEGER INCV, LDC, M, N
+* DOUBLE PRECISION TAU
+* ..
+* .. Array Arguments ..
+* DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> DLARF1L applies a real elementary reflector H to a real m by n matrix
+*> C, from either the left or the right. H is represented in the form
+*>
+*> H = I - tau * v * v**T
+*>
+*> where tau is a real scalar and v is a real vector.
+*>
+*> If tau = 0, then H is taken to be the unit matrix.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] SIDE
+*> \verbatim
+*> SIDE is CHARACTER*1
+*> = 'L': form H * C
+*> = 'R': form C * H
+*> \endverbatim
+*>
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows of the matrix C.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of columns of the matrix C.
+*> \endverbatim
+*>
+*> \param[in] V
+*> \verbatim
+*> V is DOUBLE PRECISION array, dimension
+*> (1 + (M-1)*abs(INCV)) if SIDE = 'L'
+*> or (1 + (N-1)*abs(INCV)) if SIDE = 'R'
+*> The vector v in the representation of H. V is not used if
+*> TAU = 0.
+*> \endverbatim
+*>
+*> \param[in] INCV
+*> \verbatim
+*> INCV is INTEGER
+*> The increment between elements of v. INCV <> 0.
+*> \endverbatim
+*>
+*> \param[in] TAU
+*> \verbatim
+*> TAU is DOUBLE PRECISION
+*> The value tau in the representation of H.
+*> \endverbatim
+*>
+*> \param[in,out] C
+*> \verbatim
+*> C is DOUBLE PRECISION array, dimension (LDC,N)
+*> On entry, the m by n matrix C.
+*> On exit, C is overwritten by the matrix H * C if SIDE = 'L',
+*> or C * H if SIDE = 'R'.
+*> \endverbatim
+*>
+*> \param[in] LDC
+*> \verbatim
+*> LDC is INTEGER
+*> The leading dimension of the array C. LDC >= max(1,M).
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is DOUBLE PRECISION array, dimension
+*> (N) if SIDE = 'L'
+*> or (M) if SIDE = 'R'
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \ingroup larf
+*
+* =====================================================================
+ SUBROUTINE DLARF1L( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )
+ IMPLICIT NONE
+*
+* -- LAPACK auxiliary routine --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+*
+* .. Scalar Arguments ..
+ CHARACTER SIDE
+ INTEGER INCV, LDC, M, N
+ DOUBLE PRECISION TAU
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE, ZERO
+ PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL APPLYLEFT
+ INTEGER I, FIRSTV, LASTV, LASTC
+* ..
+* .. External Subroutines ..
+ EXTERNAL DAXPY, DGEMV, DGER, DSCAL
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILADLR, ILADLC
+ EXTERNAL LSAME, ILADLR, ILADLC
+* ..
+* .. Executable Statements ..
+*
+ APPLYLEFT = LSAME( SIDE, 'L' )
+ FIRSTV = 1
+ LASTC = 0
+ IF( TAU.NE.ZERO ) THEN
+! Set up variables for scanning V. LASTV begins pointing to the end
+! of V.
+ IF( APPLYLEFT ) THEN
+ LASTV = M
+ ELSE
+ LASTV = N
+ END IF
+ I = 1
+! Look for the last non-zero row in V.
+ DO WHILE( LASTV.GT.FIRSTV .AND. V( I ).EQ.ZERO )
+ FIRSTV = FIRSTV + 1
+ I = I + INCV
+ END DO
+ IF( APPLYLEFT ) THEN
+! Scan for the last non-zero column in C(1:lastv,:).
+ LASTC = ILADLC(LASTV, N, C, LDC)
+ ELSE
+! Scan for the last non-zero row in C(:,1:lastv).
+ LASTC = ILADLR(M, LASTV, C, LDC)
+ END IF
+ END IF
+ IF( LASTC.EQ.0 ) THEN
+ RETURN
+ END IF
+ IF( APPLYLEFT ) THEN
+*
+* Form H * C
+*
+ IF( LASTV.GT.0 ) THEN
+ ! Check if m = 1. This means v = 1, So we just need to compute
+ ! C := HC = (1-\tau)C.
+ IF( LASTV.EQ.FIRSTV ) THEN
+ CALL DSCAL(LASTC, ONE - TAU, C( FIRSTV, 1), LDC)
+ ELSE
+*
+* w(1:lastc,1) := C(1:lastv,1:lastc)**T * v(1:lastv,1)
+*
+ ! w(1:lastc,1) := C(1:lastv-1,1:lastc)**T * v(1:lastv-1,1)
+ CALL DGEMV( 'Transpose', LASTV-FIRSTV, LASTC, ONE,
+ $ C(FIRSTV,1), LDC, V(I), INCV, ZERO,
+ $ WORK, 1)
+ ! w(1:lastc,1) += C(lastv,1:lastc)**T * v(lastv,1) = C(lastv,1:lastc)**T
+ CALL DAXPY(LASTC, ONE, C(LASTV,1), LDC, WORK, 1)
+*
+* C(1:lastv,1:lastc) := C(...) - tau * v(1:lastv,1) * w(1:lastc,1)**T
+*
+ ! C(lastv, 1:lastc) := C(...) - tau * v(lastv,1) * w(1:lastc,1)**T
+ ! = C(...) - tau * w(1:lastc,1)**T
+ CALL DAXPY(LASTC, -TAU, WORK, 1, C(LASTV,1), LDC)
+ ! C(1:lastv-1,1:lastc) := C(...) - tau * v(1:lastv-1,1)*w(1:lastc,1)**T
+ CALL DGER(LASTV-FIRSTV, LASTC, -TAU, V(I), INCV,
+ $ WORK, 1, C(FIRSTV,1), LDC)
+ END IF
+ END IF
+ ELSE
+*
+* Form C * H
+*
+ IF( LASTV.GT.0 ) THEN
+ ! Check if n = 1. This means v = 1, so we just need to compute
+ ! C := CH = C(1-\tau).
+ IF( LASTV.EQ.FIRSTV ) THEN
+ CALL DSCAL(LASTC, ONE - TAU, C, 1)
+ ELSE
+*
+* w(1:lastc,1) := C(1:lastc,1:lastv) * v(1:lastv,1)
+*
+ ! w(1:lastc,1) := C(1:lastc,1:lastv-1) * v(1:lastv-1,1)
+ CALL DGEMV( 'No transpose', LASTC, LASTV-FIRSTV,
+ $ ONE, C(1,FIRSTV), LDC, V(I), INCV, ZERO, WORK, 1 )
+ ! w(1:lastc,1) += C(1:lastc,lastv) * v(lastv,1) = C(1:lastc,lastv)
+ CALL DAXPY(LASTC, ONE, C(1,LASTV), 1, WORK, 1)
+*
+* C(1:lastc,1:lastv) := C(...) - tau * w(1:lastc,1) * v(1:lastv,1)**T
+*
+ ! C(1:lastc,lastv) := C(...) - tau * w(1:lastc,1) * v(lastv,1)**T
+ ! = C(...) - tau * w(1:lastc,1)
+ CALL DAXPY(LASTC, -TAU, WORK, 1, C(1,LASTV), 1)
+ ! C(1:lastc,1:lastv-1) := C(...) - tau * w(1:lastc,1) * v(1:lastv-1)**T
+ CALL DGER( LASTC, LASTV-FIRSTV, -TAU, WORK, 1, V(I),
+ $ INCV, C(1,FIRSTV), LDC )
+ END IF
+ END IF
+ END IF
+ RETURN
+*
+* End of DLARF1L
+*
+ END
diff --git a/lapack-netlib/SRC/dopmtr.f b/lapack-netlib/SRC/dopmtr.f
index c18074deca..5646b8eacc 100644
--- a/lapack-netlib/SRC/dopmtr.f
+++ b/lapack-netlib/SRC/dopmtr.f
@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
-*> \htmlonly
*> Download DOPMTR + dependencies
*>
*> [TGZ]
@@ -13,7 +12,6 @@
*> [ZIP]
*>
*> [TXT]
-*> \endhtmlonly
*
* Definition:
* ===========
@@ -142,11 +140,13 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \ingroup doubleOTHERcomputational
+*> \ingroup upmtr
*
* =====================================================================
- SUBROUTINE DOPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC, WORK,
+ SUBROUTINE DOPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC,
+ $ WORK,
$ INFO )
+ IMPLICIT NONE
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
@@ -260,11 +260,9 @@ SUBROUTINE DOPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC, WORK,
*
* Apply H(i)
*
- AII = AP( II )
- AP( II ) = ONE
- CALL DLARF( SIDE, MI, NI, AP( II-I+1 ), 1, TAU( I ), C, LDC,
+ CALL DLARF1L( SIDE, MI, NI, AP( II-I+1 ), 1, TAU( I ), C,
+ $ LDC,
$ WORK )
- AP( II ) = AII
*
IF( FORWRD ) THEN
II = II + I + 2
diff --git a/lapack-netlib/SRC/dorbdb.f b/lapack-netlib/SRC/dorbdb.f
index 3edfda6b84..08be1794a6 100644
--- a/lapack-netlib/SRC/dorbdb.f
+++ b/lapack-netlib/SRC/dorbdb.f
@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
-*> \htmlonly
*> Download DORBDB + dependencies
*>
*> [TGZ]
@@ -13,7 +12,6 @@
*> [ZIP]
*>
*> [TXT]
-*> \endhtmlonly
*
* Definition:
* ===========
@@ -255,7 +253,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \ingroup doubleOTHERcomputational
+*> \ingroup unbdb
*
*> \par Further Details:
* =====================
@@ -281,9 +279,11 @@
*> Algorithms, 50(1):33-65, 2009.
*>
* =====================================================================
- SUBROUTINE DORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12,
+ SUBROUTINE DORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12,
+ $ LDX12,
$ X21, LDX21, X22, LDX22, THETA, PHI, TAUP1,
$ TAUP2, TAUQ1, TAUQ2, WORK, LWORK, INFO )
+ IMPLICIT NONE
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
@@ -315,7 +315,8 @@ SUBROUTINE DORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12,
DOUBLE PRECISION Z1, Z2, Z3, Z4
* ..
* .. External Subroutines ..
- EXTERNAL DAXPY, DLARF, DLARFGP, DSCAL, XERBLA
+ EXTERNAL DAXPY, DLARF1F, DLARFGP, DSCAL,
+ $ XERBLA
* ..
* .. External Functions ..
DOUBLE PRECISION DNRM2
@@ -398,14 +399,16 @@ SUBROUTINE DORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12,
CALL DSCAL( P-I+1, Z1, X11(I,I), 1 )
ELSE
CALL DSCAL( P-I+1, Z1*COS(PHI(I-1)), X11(I,I), 1 )
- CALL DAXPY( P-I+1, -Z1*Z3*Z4*SIN(PHI(I-1)), X12(I,I-1),
+ CALL DAXPY( P-I+1, -Z1*Z3*Z4*SIN(PHI(I-1)), X12(I,
+ $ I-1),
$ 1, X11(I,I), 1 )
END IF
IF( I .EQ. 1 ) THEN
CALL DSCAL( M-P-I+1, Z2, X21(I,I), 1 )
ELSE
CALL DSCAL( M-P-I+1, Z2*COS(PHI(I-1)), X21(I,I), 1 )
- CALL DAXPY( M-P-I+1, -Z2*Z3*Z4*SIN(PHI(I-1)), X22(I,I-1),
+ CALL DAXPY( M-P-I+1, -Z2*Z3*Z4*SIN(PHI(I-1)), X22(I,
+ $ I-1),
$ 1, X21(I,I), 1 )
END IF
*
@@ -413,44 +416,48 @@ SUBROUTINE DORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12,
$ DNRM2( P-I+1, X11(I,I), 1 ) )
*
IF( P .GT. I ) THEN
- CALL DLARFGP( P-I+1, X11(I,I), X11(I+1,I), 1, TAUP1(I) )
+ CALL DLARFGP( P-I+1, X11(I,I), X11(I+1,I), 1,
+ $ TAUP1(I) )
ELSE IF( P .EQ. I ) THEN
CALL DLARFGP( P-I+1, X11(I,I), X11(I,I), 1, TAUP1(I) )
END IF
- X11(I,I) = ONE
IF ( M-P .GT. I ) THEN
CALL DLARFGP( M-P-I+1, X21(I,I), X21(I+1,I), 1,
$ TAUP2(I) )
ELSE IF ( M-P .EQ. I ) THEN
- CALL DLARFGP( M-P-I+1, X21(I,I), X21(I,I), 1, TAUP2(I) )
+ CALL DLARFGP( M-P-I+1, X21(I,I), X21(I,I), 1,
+ $ TAUP2(I) )
END IF
- X21(I,I) = ONE
*
IF ( Q .GT. I ) THEN
- CALL DLARF( 'L', P-I+1, Q-I, X11(I,I), 1, TAUP1(I),
+ CALL DLARF1F( 'L', P-I+1, Q-I, X11(I,I), 1, TAUP1(I),
$ X11(I,I+1), LDX11, WORK )
END IF
IF ( M-Q+1 .GT. I ) THEN
- CALL DLARF( 'L', P-I+1, M-Q-I+1, X11(I,I), 1, TAUP1(I),
+ CALL DLARF1F( 'L', P-I+1, M-Q-I+1, X11(I,I), 1,
+ $ TAUP1(I),
$ X12(I,I), LDX12, WORK )
END IF
IF ( Q .GT. I ) THEN
- CALL DLARF( 'L', M-P-I+1, Q-I, X21(I,I), 1, TAUP2(I),
- $ X21(I,I+1), LDX21, WORK )
+ CALL DLARF1F( 'L', M-P-I+1, Q-I, X21(I,I), 1,
+ $ TAUP2(I), X21(I,I+1), LDX21, WORK )
END IF
IF ( M-Q+1 .GT. I ) THEN
- CALL DLARF( 'L', M-P-I+1, M-Q-I+1, X21(I,I), 1, TAUP2(I),
- $ X22(I,I), LDX22, WORK )
+ CALL DLARF1F( 'L', M-P-I+1, M-Q-I+1, X21(I,I), 1,
+ $ TAUP2(I), X22(I,I), LDX22, WORK )
END IF
*
IF( I .LT. Q ) THEN
CALL DSCAL( Q-I, -Z1*Z3*SIN(THETA(I)), X11(I,I+1),
$ LDX11 )
- CALL DAXPY( Q-I, Z2*Z3*COS(THETA(I)), X21(I,I+1), LDX21,
+ CALL DAXPY( Q-I, Z2*Z3*COS(THETA(I)), X21(I,I+1),
+ $ LDX21,
$ X11(I,I+1), LDX11 )
END IF
- CALL DSCAL( M-Q-I+1, -Z1*Z4*SIN(THETA(I)), X12(I,I), LDX12 )
- CALL DAXPY( M-Q-I+1, Z2*Z4*COS(THETA(I)), X22(I,I), LDX22,
+ CALL DSCAL( M-Q-I+1, -Z1*Z4*SIN(THETA(I)), X12(I,I),
+ $ LDX12 )
+ CALL DAXPY( M-Q-I+1, Z2*Z4*COS(THETA(I)), X22(I,I),
+ $ LDX22,
$ X12(I,I), LDX12 )
*
IF( I .LT. Q )
@@ -465,7 +472,6 @@ SUBROUTINE DORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12,
CALL DLARFGP( Q-I, X11(I,I+1), X11(I,I+2), LDX11,
$ TAUQ1(I) )
END IF
- X11(I,I+1) = ONE
END IF
IF ( Q+I-1 .LT. M ) THEN
IF ( M-Q .EQ. I ) THEN
@@ -476,20 +482,22 @@ SUBROUTINE DORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12,
$ TAUQ2(I) )
END IF
END IF
- X12(I,I) = ONE
*
IF( I .LT. Q ) THEN
- CALL DLARF( 'R', P-I, Q-I, X11(I,I+1), LDX11, TAUQ1(I),
+ CALL DLARF1F( 'R', P-I, Q-I, X11(I,I+1), LDX11,
+ $ TAUQ1(I),
$ X11(I+1,I+1), LDX11, WORK )
- CALL DLARF( 'R', M-P-I, Q-I, X11(I,I+1), LDX11, TAUQ1(I),
+ CALL DLARF1F( 'R', M-P-I, Q-I, X11(I,I+1), LDX11,
+ $ TAUQ1(I),
$ X21(I+1,I+1), LDX21, WORK )
END IF
IF ( P .GT. I ) THEN
- CALL DLARF( 'R', P-I, M-Q-I+1, X12(I,I), LDX12, TAUQ2(I),
+ CALL DLARF1F( 'R', P-I, M-Q-I+1, X12(I,I), LDX12,
+ $ TAUQ2(I),
$ X12(I+1,I), LDX12, WORK )
END IF
IF ( M-P .GT. I ) THEN
- CALL DLARF( 'R', M-P-I, M-Q-I+1, X12(I,I), LDX12,
+ CALL DLARF1F( 'R', M-P-I, M-Q-I+1, X12(I,I), LDX12,
$ TAUQ2(I), X22(I+1,I), LDX22, WORK )
END IF
*
@@ -507,14 +515,14 @@ SUBROUTINE DORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12,
CALL DLARFGP( M-Q-I+1, X12(I,I), X12(I,I+1), LDX12,
$ TAUQ2(I) )
END IF
- X12(I,I) = ONE
*
IF ( P .GT. I ) THEN
- CALL DLARF( 'R', P-I, M-Q-I+1, X12(I,I), LDX12, TAUQ2(I),
+ CALL DLARF1F( 'R', P-I, M-Q-I+1, X12(I,I), LDX12,
+ $ TAUQ2(I),
$ X12(I+1,I), LDX12, WORK )
END IF
IF( M-P-Q .GE. 1 )
- $ CALL DLARF( 'R', M-P-Q, M-Q-I+1, X12(I,I), LDX12,
+ $ CALL DLARF1F( 'R', M-P-Q, M-Q-I+1, X12(I,I), LDX12,
$ TAUQ2(I), X22(Q+1,I), LDX22, WORK )
*
END DO
@@ -531,9 +539,9 @@ SUBROUTINE DORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12,
CALL DLARFGP( M-P-Q-I+1, X22(Q+I,P+I), X22(Q+I,P+I+1),
$ LDX22, TAUQ2(P+I) )
END IF
- X22(Q+I,P+I) = ONE
IF ( I .LT. M-P-Q ) THEN
- CALL DLARF( 'R', M-P-Q-I, M-P-Q-I+1, X22(Q+I,P+I), LDX22,
+ CALL DLARF1F( 'R', M-P-Q-I, M-P-Q-I+1, X22(Q+I,P+I),
+ $ LDX22,
$ TAUQ2(P+I), X22(Q+I+1,P+I), LDX22, WORK )
END IF
*
@@ -549,22 +557,25 @@ SUBROUTINE DORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12,
CALL DSCAL( P-I+1, Z1, X11(I,I), LDX11 )
ELSE
CALL DSCAL( P-I+1, Z1*COS(PHI(I-1)), X11(I,I), LDX11 )
- CALL DAXPY( P-I+1, -Z1*Z3*Z4*SIN(PHI(I-1)), X12(I-1,I),
+ CALL DAXPY( P-I+1, -Z1*Z3*Z4*SIN(PHI(I-1)), X12(I-1,
+ $ I),
$ LDX12, X11(I,I), LDX11 )
END IF
IF( I .EQ. 1 ) THEN
CALL DSCAL( M-P-I+1, Z2, X21(I,I), LDX21 )
ELSE
- CALL DSCAL( M-P-I+1, Z2*COS(PHI(I-1)), X21(I,I), LDX21 )
- CALL DAXPY( M-P-I+1, -Z2*Z3*Z4*SIN(PHI(I-1)), X22(I-1,I),
+ CALL DSCAL( M-P-I+1, Z2*COS(PHI(I-1)), X21(I,I),
+ $ LDX21 )
+ CALL DAXPY( M-P-I+1, -Z2*Z3*Z4*SIN(PHI(I-1)), X22(I-1,
+ $ I),
$ LDX22, X21(I,I), LDX21 )
END IF
*
THETA(I) = ATAN2( DNRM2( M-P-I+1, X21(I,I), LDX21 ),
$ DNRM2( P-I+1, X11(I,I), LDX11 ) )
*
- CALL DLARFGP( P-I+1, X11(I,I), X11(I,I+1), LDX11, TAUP1(I) )
- X11(I,I) = ONE
+ CALL DLARFGP( P-I+1, X11(I,I), X11(I,I+1), LDX11,
+ $ TAUP1(I) )
IF ( I .EQ. M-P ) THEN
CALL DLARFGP( M-P-I+1, X21(I,I), X21(I,I), LDX21,
$ TAUP2(I) )
@@ -572,22 +583,23 @@ SUBROUTINE DORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12,
CALL DLARFGP( M-P-I+1, X21(I,I), X21(I,I+1), LDX21,
$ TAUP2(I) )
END IF
- X21(I,I) = ONE
*
IF ( Q .GT. I ) THEN
- CALL DLARF( 'R', Q-I, P-I+1, X11(I,I), LDX11, TAUP1(I),
+ CALL DLARF1F( 'R', Q-I, P-I+1, X11(I,I), LDX11,
+ $ TAUP1(I),
$ X11(I+1,I), LDX11, WORK )
END IF
IF ( M-Q+1 .GT. I ) THEN
- CALL DLARF( 'R', M-Q-I+1, P-I+1, X11(I,I), LDX11,
+ CALL DLARF1F( 'R', M-Q-I+1, P-I+1, X11(I,I), LDX11,
$ TAUP1(I), X12(I,I), LDX12, WORK )
END IF
IF ( Q .GT. I ) THEN
- CALL DLARF( 'R', Q-I, M-P-I+1, X21(I,I), LDX21, TAUP2(I),
+ CALL DLARF1F( 'R', Q-I, M-P-I+1, X21(I,I), LDX21,
+ $ TAUP2(I),
$ X21(I+1,I), LDX21, WORK )
END IF
IF ( M-Q+1 .GT. I ) THEN
- CALL DLARF( 'R', M-Q-I+1, M-P-I+1, X21(I,I), LDX21,
+ CALL DLARF1F( 'R', M-Q-I+1, M-P-I+1, X21(I,I), LDX21,
$ TAUP2(I), X22(I,I), LDX22, WORK )
END IF
*
@@ -612,7 +624,6 @@ SUBROUTINE DORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12,
CALL DLARFGP( Q-I, X11(I+1,I), X11(I+2,I), 1,
$ TAUQ1(I) )
END IF
- X11(I+1,I) = ONE
END IF
IF ( M-Q .GT. I ) THEN
CALL DLARFGP( M-Q-I+1, X12(I,I), X12(I+1,I), 1,
@@ -621,19 +632,18 @@ SUBROUTINE DORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12,
CALL DLARFGP( M-Q-I+1, X12(I,I), X12(I,I), 1,
$ TAUQ2(I) )
END IF
- X12(I,I) = ONE
*
IF( I .LT. Q ) THEN
- CALL DLARF( 'L', Q-I, P-I, X11(I+1,I), 1, TAUQ1(I),
+ CALL DLARF1F( 'L', Q-I, P-I, X11(I+1,I), 1, TAUQ1(I),
$ X11(I+1,I+1), LDX11, WORK )
- CALL DLARF( 'L', Q-I, M-P-I, X11(I+1,I), 1, TAUQ1(I),
- $ X21(I+1,I+1), LDX21, WORK )
+ CALL DLARF1F( 'L', Q-I, M-P-I, X11(I+1,I), 1,
+ $ TAUQ1(I), X21(I+1,I+1), LDX21, WORK )
END IF
- CALL DLARF( 'L', M-Q-I+1, P-I, X12(I,I), 1, TAUQ2(I),
- $ X12(I,I+1), LDX12, WORK )
+ CALL DLARF1F( 'L', M-Q-I+1, P-I, X12(I,I), 1, TAUQ2(I),
+ $ X12(I,I+1), LDX12, WORK )
IF ( M-P-I .GT. 0 ) THEN
- CALL DLARF( 'L', M-Q-I+1, M-P-I, X12(I,I), 1, TAUQ2(I),
- $ X22(I,I+1), LDX22, WORK )
+ CALL DLARF1F( 'L', M-Q-I+1, M-P-I, X12(I,I), 1,
+ $ TAUQ2(I), X22(I,I+1), LDX22, WORK )
END IF
*
END DO
@@ -643,16 +653,16 @@ SUBROUTINE DORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12,
DO I = Q + 1, P
*
CALL DSCAL( M-Q-I+1, -Z1*Z4, X12(I,I), 1 )
- CALL DLARFGP( M-Q-I+1, X12(I,I), X12(I+1,I), 1, TAUQ2(I) )
- X12(I,I) = ONE
+ CALL DLARFGP( M-Q-I+1, X12(I,I), X12(I+1,I), 1,
+ $ TAUQ2(I) )
*
IF ( P .GT. I ) THEN
- CALL DLARF( 'L', M-Q-I+1, P-I, X12(I,I), 1, TAUQ2(I),
- $ X12(I,I+1), LDX12, WORK )
+ CALL DLARF1F( 'L', M-Q-I+1, P-I, X12(I,I), 1,
+ $ TAUQ2(I), X12(I,I+1), LDX12, WORK )
END IF
IF( M-P-Q .GE. 1 )
- $ CALL DLARF( 'L', M-Q-I+1, M-P-Q, X12(I,I), 1, TAUQ2(I),
- $ X22(I,Q+1), LDX22, WORK )
+ $ CALL DLARF1F( 'L', M-Q-I+1, M-P-Q, X12(I,I), 1,
+ $ TAUQ2(I), X22(I,Q+1), LDX22, WORK )
*
END DO
*
@@ -662,15 +672,17 @@ SUBROUTINE DORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12,
*
CALL DSCAL( M-P-Q-I+1, Z2*Z4, X22(P+I,Q+I), 1 )
IF ( M-P-Q .EQ. I ) THEN
- CALL DLARFGP( M-P-Q-I+1, X22(P+I,Q+I), X22(P+I,Q+I), 1,
+ CALL DLARFGP( M-P-Q-I+1, X22(P+I,Q+I), X22(P+I,Q+I),
+ $ 1,
$ TAUQ2(P+I) )
ELSE
- CALL DLARFGP( M-P-Q-I+1, X22(P+I,Q+I), X22(P+I+1,Q+I), 1,
+ CALL DLARFGP( M-P-Q-I+1, X22(P+I,Q+I), X22(P+I+1,Q+I),
+ $ 1,
$ TAUQ2(P+I) )
- CALL DLARF( 'L', M-P-Q-I+1, M-P-Q-I, X22(P+I,Q+I), 1,
- $ TAUQ2(P+I), X22(P+I,Q+I+1), LDX22, WORK )
+ CALL DLARF1F( 'L', M-P-Q-I+1, M-P-Q-I, X22(P+I,Q+I),
+ $ 1, TAUQ2(P+I), X22(P+I,Q+I+1), LDX22,
+ $ WORK )
END IF
- X22(P+I,Q+I) = ONE
*
END DO
*
diff --git a/lapack-netlib/SRC/dorbdb1.f b/lapack-netlib/SRC/dorbdb1.f
index b5b2d13623..c52293bb68 100644
--- a/lapack-netlib/SRC/dorbdb1.f
+++ b/lapack-netlib/SRC/dorbdb1.f
@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
-*> \htmlonly
*> Download DORBDB1 + dependencies
*>
*> [TGZ]
@@ -13,7 +12,6 @@
*> [ZIP]
*>
*> [TXT]
-*> \endhtmlonly
*
* Definition:
* ===========
@@ -174,7 +172,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \ingroup doubleOTHERcomputational
+*> \ingroup unbdb1
*
*> \par Further Details:
* =====================
@@ -198,8 +196,10 @@
*> Algorithms, 50(1):33-65, 2009.
*>
* =====================================================================
- SUBROUTINE DORBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
+ SUBROUTINE DORBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA,
+ $ PHI,
$ TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO )
+ IMPLICIT NONE
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
@@ -227,7 +227,8 @@ SUBROUTINE DORBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
LOGICAL LQUERY
* ..
* .. External Subroutines ..
- EXTERNAL DLARF, DLARFGP, DORBDB5, DROT, XERBLA
+ EXTERNAL DLARF1F, DLARFGP, DORBDB5, DROT,
+ $ XERBLA
* ..
* .. External Functions ..
DOUBLE PRECISION DNRM2
@@ -285,22 +286,23 @@ SUBROUTINE DORBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
THETA(I) = ATAN2( X21(I,I), X11(I,I) )
C = COS( THETA(I) )
S = SIN( THETA(I) )
- X11(I,I) = ONE
- X21(I,I) = ONE
- CALL DLARF( 'L', P-I+1, Q-I, X11(I,I), 1, TAUP1(I), X11(I,I+1),
+ CALL DLARF1F( 'L', P-I+1, Q-I, X11(I,I), 1, TAUP1(I), X11(I,
+ $ I+1),
$ LDX11, WORK(ILARF) )
- CALL DLARF( 'L', M-P-I+1, Q-I, X21(I,I), 1, TAUP2(I),
+ CALL DLARF1F( 'L', M-P-I+1, Q-I, X21(I,I), 1, TAUP2(I),
$ X21(I,I+1), LDX21, WORK(ILARF) )
*
IF( I .LT. Q ) THEN
- CALL DROT( Q-I, X11(I,I+1), LDX11, X21(I,I+1), LDX21, C, S )
- CALL DLARFGP( Q-I, X21(I,I+1), X21(I,I+2), LDX21, TAUQ1(I) )
+ CALL DROT( Q-I, X11(I,I+1), LDX11, X21(I,I+1), LDX21, C,
+ $ S )
+ CALL DLARFGP( Q-I, X21(I,I+1), X21(I,I+2), LDX21,
+ $ TAUQ1(I) )
S = X21(I,I+1)
- X21(I,I+1) = ONE
- CALL DLARF( 'R', P-I, Q-I, X21(I,I+1), LDX21, TAUQ1(I),
+ CALL DLARF1F( 'R', P-I, Q-I, X21(I,I+1), LDX21, TAUQ1(I),
$ X11(I+1,I+1), LDX11, WORK(ILARF) )
- CALL DLARF( 'R', M-P-I, Q-I, X21(I,I+1), LDX21, TAUQ1(I),
- $ X21(I+1,I+1), LDX21, WORK(ILARF) )
+ CALL DLARF1F( 'R', M-P-I, Q-I, X21(I,I+1), LDX21,
+ $ TAUQ1(I), X21(I+1,I+1), LDX21,
+ $ WORK(ILARF) )
C = SQRT( DNRM2( P-I, X11(I+1,I+1), 1 )**2
$ + DNRM2( M-P-I, X21(I+1,I+1), 1 )**2 )
PHI(I) = ATAN2( S, C )
diff --git a/lapack-netlib/SRC/dorbdb2.f b/lapack-netlib/SRC/dorbdb2.f
index 0b4ad732c1..8a5b8d9bae 100644
--- a/lapack-netlib/SRC/dorbdb2.f
+++ b/lapack-netlib/SRC/dorbdb2.f
@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
-*> \htmlonly
*> Download DORBDB2 + dependencies
*>
*> [TGZ]
@@ -13,7 +12,6 @@
*> [ZIP]
*>
*> [TXT]
-*> \endhtmlonly
*
* Definition:
* ===========
@@ -173,7 +171,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \ingroup doubleOTHERcomputational
+*> \ingroup unbdb2
*
*> \par Further Details:
* =====================
@@ -197,8 +195,10 @@
*> Algorithms, 50(1):33-65, 2009.
*>
* =====================================================================
- SUBROUTINE DORBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
+ SUBROUTINE DORBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA,
+ $ PHI,
$ TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO )
+ IMPLICIT NONE
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
@@ -226,7 +226,8 @@ SUBROUTINE DORBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
LOGICAL LQUERY
* ..
* .. External Subroutines ..
- EXTERNAL DLARF, DLARFGP, DORBDB5, DROT, DSCAL, XERBLA
+ EXTERNAL DLARF1F, DLARFGP, DORBDB5, DROT, DSCAL,
+ $ XERBLA
* ..
* .. External Functions ..
DOUBLE PRECISION DNRM2
@@ -280,15 +281,15 @@ SUBROUTINE DORBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
DO I = 1, P
*
IF( I .GT. 1 ) THEN
- CALL DROT( Q-I+1, X11(I,I), LDX11, X21(I-1,I), LDX21, C, S )
+ CALL DROT( Q-I+1, X11(I,I), LDX11, X21(I-1,I), LDX21, C,
+ $ S )
END IF
CALL DLARFGP( Q-I+1, X11(I,I), X11(I,I+1), LDX11, TAUQ1(I) )
C = X11(I,I)
- X11(I,I) = ONE
- CALL DLARF( 'R', P-I, Q-I+1, X11(I,I), LDX11, TAUQ1(I),
+ CALL DLARF1F( 'R', P-I, Q-I+1, X11(I,I), LDX11, TAUQ1(I),
$ X11(I+1,I), LDX11, WORK(ILARF) )
- CALL DLARF( 'R', M-P-I+1, Q-I+1, X11(I,I), LDX11, TAUQ1(I),
- $ X21(I,I), LDX21, WORK(ILARF) )
+ CALL DLARF1F( 'R', M-P-I+1, Q-I+1, X11(I,I), LDX11,
+ $ TAUQ1(I), X21(I,I), LDX21, WORK(ILARF) )
S = SQRT( DNRM2( P-I, X11(I+1,I), 1 )**2
$ + DNRM2( M-P-I+1, X21(I,I), 1 )**2 )
THETA(I) = ATAN2( S, C )
@@ -303,12 +304,10 @@ SUBROUTINE DORBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
PHI(I) = ATAN2( X11(I+1,I), X21(I,I) )
C = COS( PHI(I) )
S = SIN( PHI(I) )
- X11(I+1,I) = ONE
- CALL DLARF( 'L', P-I, Q-I, X11(I+1,I), 1, TAUP1(I),
+ CALL DLARF1F( 'L', P-I, Q-I, X11(I+1,I), 1, TAUP1(I),
$ X11(I+1,I+1), LDX11, WORK(ILARF) )
END IF
- X21(I,I) = ONE
- CALL DLARF( 'L', M-P-I+1, Q-I, X21(I,I), 1, TAUP2(I),
+ CALL DLARF1F( 'L', M-P-I+1, Q-I, X21(I,I), 1, TAUP2(I),
$ X21(I,I+1), LDX21, WORK(ILARF) )
*
END DO
@@ -317,8 +316,7 @@ SUBROUTINE DORBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
*
DO I = P + 1, Q
CALL DLARFGP( M-P-I+1, X21(I,I), X21(I+1,I), 1, TAUP2(I) )
- X21(I,I) = ONE
- CALL DLARF( 'L', M-P-I+1, Q-I, X21(I,I), 1, TAUP2(I),
+ CALL DLARF1F( 'L', M-P-I+1, Q-I, X21(I,I), 1, TAUP2(I),
$ X21(I,I+1), LDX21, WORK(ILARF) )
END DO
*
diff --git a/lapack-netlib/SRC/dorbdb3.f b/lapack-netlib/SRC/dorbdb3.f
index 79b10a5d36..855b711a5a 100644
--- a/lapack-netlib/SRC/dorbdb3.f
+++ b/lapack-netlib/SRC/dorbdb3.f
@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
-*> \htmlonly
*> Download DORBDB3 + dependencies
*>
*> [TGZ]
@@ -13,7 +12,6 @@
*> [ZIP]
*>
*> [TXT]
-*> \endhtmlonly
*
* Definition:
* ===========
@@ -172,7 +170,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \ingroup doubleOTHERcomputational
+*> \ingroup unbdb3
*
*> \par Further Details:
* =====================
@@ -196,8 +194,10 @@
*> Algorithms, 50(1):33-65, 2009.
*>
* =====================================================================
- SUBROUTINE DORBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
+ SUBROUTINE DORBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA,
+ $ PHI,
$ TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO )
+ IMPLICIT NONE
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
@@ -225,7 +225,8 @@ SUBROUTINE DORBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
LOGICAL LQUERY
* ..
* .. External Subroutines ..
- EXTERNAL DLARF, DLARFGP, DORBDB5, DROT, XERBLA
+ EXTERNAL DLARF1F, DLARFGP, DORBDB5, DROT,
+ $ XERBLA
* ..
* .. External Functions ..
DOUBLE PRECISION DNRM2
@@ -279,15 +280,15 @@ SUBROUTINE DORBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
DO I = 1, M-P
*
IF( I .GT. 1 ) THEN
- CALL DROT( Q-I+1, X11(I-1,I), LDX11, X21(I,I), LDX11, C, S )
+ CALL DROT( Q-I+1, X11(I-1,I), LDX11, X21(I,I), LDX11, C,
+ $ S )
END IF
*
CALL DLARFGP( Q-I+1, X21(I,I), X21(I,I+1), LDX21, TAUQ1(I) )
S = X21(I,I)
- X21(I,I) = ONE
- CALL DLARF( 'R', P-I+1, Q-I+1, X21(I,I), LDX21, TAUQ1(I),
+ CALL DLARF1F( 'R', P-I+1, Q-I+1, X21(I,I), LDX21, TAUQ1(I),
$ X11(I,I), LDX11, WORK(ILARF) )
- CALL DLARF( 'R', M-P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I),
+ CALL DLARF1F( 'R', M-P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I),
$ X21(I+1,I), LDX21, WORK(ILARF) )
C = SQRT( DNRM2( P-I+1, X11(I,I), 1 )**2
$ + DNRM2( M-P-I, X21(I+1,I), 1 )**2 )
@@ -298,16 +299,16 @@ SUBROUTINE DORBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
$ WORK(IORBDB5), LORBDB5, CHILDINFO )
CALL DLARFGP( P-I+1, X11(I,I), X11(I+1,I), 1, TAUP1(I) )
IF( I .LT. M-P ) THEN
- CALL DLARFGP( M-P-I, X21(I+1,I), X21(I+2,I), 1, TAUP2(I) )
+ CALL DLARFGP( M-P-I, X21(I+1,I), X21(I+2,I), 1,
+ $ TAUP2(I) )
PHI(I) = ATAN2( X21(I+1,I), X11(I,I) )
C = COS( PHI(I) )
S = SIN( PHI(I) )
- X21(I+1,I) = ONE
- CALL DLARF( 'L', M-P-I, Q-I, X21(I+1,I), 1, TAUP2(I),
+ CALL DLARF1F( 'L', M-P-I, Q-I, X21(I+1,I), 1, TAUP2(I),
$ X21(I+1,I+1), LDX21, WORK(ILARF) )
END IF
- X11(I,I) = ONE
- CALL DLARF( 'L', P-I+1, Q-I, X11(I,I), 1, TAUP1(I), X11(I,I+1),
+ CALL DLARF1F( 'L', P-I+1, Q-I, X11(I,I), 1, TAUP1(I), X11(I,
+ $ I+1),
$ LDX11, WORK(ILARF) )
*
END DO
@@ -316,8 +317,8 @@ SUBROUTINE DORBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
*
DO I = M-P + 1, Q
CALL DLARFGP( P-I+1, X11(I,I), X11(I+1,I), 1, TAUP1(I) )
- X11(I,I) = ONE
- CALL DLARF( 'L', P-I+1, Q-I, X11(I,I), 1, TAUP1(I), X11(I,I+1),
+ CALL DLARF1F( 'L', P-I+1, Q-I, X11(I,I), 1, TAUP1(I), X11(I,
+ $ I+1),
$ LDX11, WORK(ILARF) )
END DO
*
diff --git a/lapack-netlib/SRC/dorbdb4.f b/lapack-netlib/SRC/dorbdb4.f
index 985be3277e..6a218fa8ad 100644
--- a/lapack-netlib/SRC/dorbdb4.f
+++ b/lapack-netlib/SRC/dorbdb4.f
@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
-*> \htmlonly
*> Download DORBDB4 + dependencies
*>
*> [TGZ]
@@ -13,7 +12,6 @@
*> [ZIP]
*>
*> [TXT]
-*> \endhtmlonly
*
* Definition:
* ===========
@@ -183,7 +181,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \ingroup doubleOTHERcomputational
+*> \ingroup unbdb4
*
*> \par Further Details:
* =====================
@@ -207,9 +205,11 @@
*> Algorithms, 50(1):33-65, 2009.
*>
* =====================================================================
- SUBROUTINE DORBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
+ SUBROUTINE DORBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA,
+ $ PHI,
$ TAUP1, TAUP2, TAUQ1, PHANTOM, WORK, LWORK,
$ INFO )
+ IMPLICIT NONE
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
@@ -237,7 +237,8 @@ SUBROUTINE DORBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
LOGICAL LQUERY
* ..
* .. External Subroutines ..
- EXTERNAL DLARF, DLARFGP, DORBDB5, DROT, DSCAL, XERBLA
+ EXTERNAL DLARF, DLARFGP, DORBDB5, DROT, DSCAL,
+ $ XERBLA
* ..
* .. External Functions ..
DOUBLE PRECISION DNRM2
@@ -300,42 +301,39 @@ SUBROUTINE DORBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
$ LORBDB5, CHILDINFO )
CALL DSCAL( P, NEGONE, PHANTOM(1), 1 )
CALL DLARFGP( P, PHANTOM(1), PHANTOM(2), 1, TAUP1(1) )
- CALL DLARFGP( M-P, PHANTOM(P+1), PHANTOM(P+2), 1, TAUP2(1) )
+ CALL DLARFGP( M-P, PHANTOM(P+1), PHANTOM(P+2), 1,
+ $ TAUP2(1) )
THETA(I) = ATAN2( PHANTOM(1), PHANTOM(P+1) )
C = COS( THETA(I) )
S = SIN( THETA(I) )
- PHANTOM(1) = ONE
- PHANTOM(P+1) = ONE
- CALL DLARF( 'L', P, Q, PHANTOM(1), 1, TAUP1(1), X11, LDX11,
- $ WORK(ILARF) )
- CALL DLARF( 'L', M-P, Q, PHANTOM(P+1), 1, TAUP2(1), X21,
- $ LDX21, WORK(ILARF) )
+ CALL DLARF1F( 'L', P, Q, PHANTOM(1), 1, TAUP1(1), X11,
+ $ LDX11, WORK(ILARF) )
+ CALL DLARF1F( 'L', M-P, Q, PHANTOM(P+1), 1, TAUP2(1),
+ $ X21, LDX21, WORK(ILARF) )
ELSE
CALL DORBDB5( P-I+1, M-P-I+1, Q-I+1, X11(I,I-1), 1,
$ X21(I,I-1), 1, X11(I,I), LDX11, X21(I,I),
$ LDX21, WORK(IORBDB5), LORBDB5, CHILDINFO )
CALL DSCAL( P-I+1, NEGONE, X11(I,I-1), 1 )
- CALL DLARFGP( P-I+1, X11(I,I-1), X11(I+1,I-1), 1, TAUP1(I) )
+ CALL DLARFGP( P-I+1, X11(I,I-1), X11(I+1,I-1), 1,
+ $ TAUP1(I) )
CALL DLARFGP( M-P-I+1, X21(I,I-1), X21(I+1,I-1), 1,
$ TAUP2(I) )
THETA(I) = ATAN2( X11(I,I-1), X21(I,I-1) )
C = COS( THETA(I) )
S = SIN( THETA(I) )
- X11(I,I-1) = ONE
- X21(I,I-1) = ONE
- CALL DLARF( 'L', P-I+1, Q-I+1, X11(I,I-1), 1, TAUP1(I),
- $ X11(I,I), LDX11, WORK(ILARF) )
- CALL DLARF( 'L', M-P-I+1, Q-I+1, X21(I,I-1), 1, TAUP2(I),
- $ X21(I,I), LDX21, WORK(ILARF) )
+ CALL DLARF1F( 'L', P-I+1, Q-I+1, X11(I,I-1), 1, TAUP1(I),
+ $ X11(I,I), LDX11, WORK(ILARF) )
+ CALL DLARF1F( 'L', M-P-I+1, Q-I+1, X21(I,I-1), 1,
+ $ TAUP2(I), X21(I,I), LDX21, WORK(ILARF) )
END IF
*
CALL DROT( Q-I+1, X11(I,I), LDX11, X21(I,I), LDX21, S, -C )
CALL DLARFGP( Q-I+1, X21(I,I), X21(I,I+1), LDX21, TAUQ1(I) )
C = X21(I,I)
- X21(I,I) = ONE
- CALL DLARF( 'R', P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I),
+ CALL DLARF1F( 'R', P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I),
$ X11(I+1,I), LDX11, WORK(ILARF) )
- CALL DLARF( 'R', M-P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I),
+ CALL DLARF1F( 'R', M-P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I),
$ X21(I+1,I), LDX21, WORK(ILARF) )
IF( I .LT. M-Q ) THEN
S = SQRT( DNRM2( P-I, X11(I+1,I), 1 )**2
@@ -349,20 +347,20 @@ SUBROUTINE DORBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
*
DO I = M - Q + 1, P
CALL DLARFGP( Q-I+1, X11(I,I), X11(I,I+1), LDX11, TAUQ1(I) )
- X11(I,I) = ONE
- CALL DLARF( 'R', P-I, Q-I+1, X11(I,I), LDX11, TAUQ1(I),
+ CALL DLARF1F( 'R', P-I, Q-I+1, X11(I,I), LDX11, TAUQ1(I),
$ X11(I+1,I), LDX11, WORK(ILARF) )
- CALL DLARF( 'R', Q-P, Q-I+1, X11(I,I), LDX11, TAUQ1(I),
+ CALL DLARF1F( 'R', Q-P, Q-I+1, X11(I,I), LDX11, TAUQ1(I),
$ X21(M-Q+1,I), LDX21, WORK(ILARF) )
END DO
*
* Reduce the bottom-right portion of X21 to [ 0 I ]
*
DO I = P + 1, Q
- CALL DLARFGP( Q-I+1, X21(M-Q+I-P,I), X21(M-Q+I-P,I+1), LDX21,
+ CALL DLARFGP( Q-I+1, X21(M-Q+I-P,I), X21(M-Q+I-P,I+1),
+ $ LDX21,
$ TAUQ1(I) )
- X21(M-Q+I-P,I) = ONE
- CALL DLARF( 'R', Q-I, Q-I+1, X21(M-Q+I-P,I), LDX21, TAUQ1(I),
+ CALL DLARF1F( 'R', Q-I, Q-I+1, X21(M-Q+I-P,I), LDX21,
+ $ TAUQ1(I),
$ X21(M-Q+I-P+1,I), LDX21, WORK(ILARF) )
END DO
*
diff --git a/lapack-netlib/SRC/dorg2l.f b/lapack-netlib/SRC/dorg2l.f
index 0a42d4cf5a..5111fa19ff 100644
--- a/lapack-netlib/SRC/dorg2l.f
+++ b/lapack-netlib/SRC/dorg2l.f
@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
-*> \htmlonly
*> Download DORG2L + dependencies
*>
*> [TGZ]
@@ -13,7 +12,6 @@
*> [ZIP]
*>
*> [TXT]
-*> \endhtmlonly
*
* Definition:
* ===========
@@ -107,10 +105,11 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \ingroup doubleOTHERcomputational
+*> \ingroup ung2l
*
* =====================================================================
SUBROUTINE DORG2L( M, N, K, A, LDA, TAU, WORK, INFO )
+ IMPLICIT NONE
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
@@ -133,7 +132,7 @@ SUBROUTINE DORG2L( M, N, K, A, LDA, TAU, WORK, INFO )
INTEGER I, II, J, L
* ..
* .. External Subroutines ..
- EXTERNAL DLARF, DSCAL, XERBLA
+ EXTERNAL DLARF1L, DSCAL, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
@@ -176,8 +175,9 @@ SUBROUTINE DORG2L( M, N, K, A, LDA, TAU, WORK, INFO )
*
* Apply H(i) to A(1:m-k+i,1:n-k+i) from the left
*
- A( M-N+II, II ) = ONE
- CALL DLARF( 'Left', M-N+II, II-1, A( 1, II ), 1, TAU( I ), A,
+ !A(M-N+II, II) = ONE
+ CALL DLARF1L( 'Left', M-N+II, II-1, A( 1, II ), 1, TAU( I ),
+ $ A,
$ LDA, WORK )
CALL DSCAL( M-N+II-1, -TAU( I ), A( 1, II ), 1 )
A( M-N+II, II ) = ONE - TAU( I )
diff --git a/lapack-netlib/SRC/dorg2r.f b/lapack-netlib/SRC/dorg2r.f
index c64ad4b0ac..213a2d54c5 100644
--- a/lapack-netlib/SRC/dorg2r.f
+++ b/lapack-netlib/SRC/dorg2r.f
@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
-*> \htmlonly
*> Download DORG2R + dependencies
*>
*> [TGZ]
@@ -13,7 +12,6 @@
*> [ZIP]
*>
*> [TXT]
-*> \endhtmlonly
*
* Definition:
* ===========
@@ -107,10 +105,11 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \ingroup doubleOTHERcomputational
+*> \ingroup ung2r
*
* =====================================================================
SUBROUTINE DORG2R( M, N, K, A, LDA, TAU, WORK, INFO )
+ IMPLICIT NONE
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
@@ -133,7 +132,7 @@ SUBROUTINE DORG2R( M, N, K, A, LDA, TAU, WORK, INFO )
INTEGER I, J, L
* ..
* .. External Subroutines ..
- EXTERNAL DLARF, DSCAL, XERBLA
+ EXTERNAL DLARF1F, DSCAL, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
@@ -176,8 +175,7 @@ SUBROUTINE DORG2R( M, N, K, A, LDA, TAU, WORK, INFO )
* Apply H(i) to A(i:m,i:n) from the left
*
IF( I.LT.N ) THEN
- A( I, I ) = ONE
- CALL DLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ),
+ CALL DLARF1F( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ),
$ A( I, I+1 ), LDA, WORK )
END IF
IF( I.LT.M )
diff --git a/lapack-netlib/SRC/dorgl2.f b/lapack-netlib/SRC/dorgl2.f
index ce1d2c6750..d8f10ebbe5 100644
--- a/lapack-netlib/SRC/dorgl2.f
+++ b/lapack-netlib/SRC/dorgl2.f
@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
-*> \htmlonly
*> Download DORGL2 + dependencies
*>
*> [TGZ]
@@ -13,7 +12,6 @@
*> [ZIP]
*>
*> [TXT]
-*> \endhtmlonly
*
* Definition:
* ===========
@@ -106,10 +104,11 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \ingroup doubleOTHERcomputational
+*> \ingroup ungl2
*
* =====================================================================
SUBROUTINE DORGL2( M, N, K, A, LDA, TAU, WORK, INFO )
+ IMPLICIT NONE
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
@@ -132,7 +131,7 @@ SUBROUTINE DORGL2( M, N, K, A, LDA, TAU, WORK, INFO )
INTEGER I, J, L
* ..
* .. External Subroutines ..
- EXTERNAL DLARF, DSCAL, XERBLA
+ EXTERNAL DLARF1F, DSCAL, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
@@ -180,8 +179,7 @@ SUBROUTINE DORGL2( M, N, K, A, LDA, TAU, WORK, INFO )
*
IF( I.LT.N ) THEN
IF( I.LT.M ) THEN
- A( I, I ) = ONE
- CALL DLARF( 'Right', M-I, N-I+1, A( I, I ), LDA,
+ CALL DLARF1F( 'Right', M-I, N-I+1, A( I, I ), LDA,
$ TAU( I ), A( I+1, I ), LDA, WORK )
END IF
CALL DSCAL( N-I, -TAU( I ), A( I, I+1 ), LDA )
diff --git a/lapack-netlib/SRC/dorm2l.f b/lapack-netlib/SRC/dorm2l.f
index c99039c541..f86a12f3a6 100644
--- a/lapack-netlib/SRC/dorm2l.f
+++ b/lapack-netlib/SRC/dorm2l.f
@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
-*> \htmlonly
*> Download DORM2L + dependencies
*>
*> [TGZ]
@@ -13,7 +12,6 @@
*> [ZIP]
*>
*> [TXT]
-*> \endhtmlonly
*
* Definition:
* ===========
@@ -98,7 +96,6 @@
*> The i-th column must contain the vector which defines the
*> elementary reflector H(i), for i = 1,2,...,k, as returned by
*> DGEQLF in the last k columns of its array argument A.
-*> A is modified by the routine but restored on exit.
*> \endverbatim
*>
*> \param[in] LDA
@@ -151,11 +148,12 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \ingroup doubleOTHERcomputational
+*> \ingroup unm2l
*
* =====================================================================
SUBROUTINE DORM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
$ WORK, INFO )
+ IMPLICIT NONE
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
@@ -178,14 +176,13 @@ SUBROUTINE DORM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
* .. Local Scalars ..
LOGICAL LEFT, NOTRAN
INTEGER I, I1, I2, I3, MI, NI, NQ
- DOUBLE PRECISION AII
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
- EXTERNAL DLARF, XERBLA
+ EXTERNAL DLARF1L, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
@@ -262,11 +259,8 @@ SUBROUTINE DORM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
*
* Apply H(i)
*
- AII = A( NQ-K+I, I )
- A( NQ-K+I, I ) = ONE
- CALL DLARF( SIDE, MI, NI, A( 1, I ), 1, TAU( I ), C, LDC,
+ CALL DLARF1L( SIDE, MI, NI, A( 1, I ), 1, TAU( I ), C, LDC,
$ WORK )
- A( NQ-K+I, I ) = AII
10 CONTINUE
RETURN
*
diff --git a/lapack-netlib/SRC/dorm2r.f b/lapack-netlib/SRC/dorm2r.f
index ac88eec8dc..0bda2b1497 100644
--- a/lapack-netlib/SRC/dorm2r.f
+++ b/lapack-netlib/SRC/dorm2r.f
@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
-*> \htmlonly
*> Download DORM2R + dependencies
*>
*> [TGZ]
@@ -13,7 +12,6 @@
*> [ZIP]
*>
*> [TXT]
-*> \endhtmlonly
*
* Definition:
* ===========
@@ -98,7 +96,6 @@
*> The i-th column must contain the vector which defines the
*> elementary reflector H(i), for i = 1,2,...,k, as returned by
*> DGEQRF in the first k columns of its array argument A.
-*> A is modified by the routine but restored on exit.
*> \endverbatim
*>
*> \param[in] LDA
@@ -151,11 +148,12 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \ingroup doubleOTHERcomputational
+*> \ingroup unm2r
*
* =====================================================================
SUBROUTINE DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
$ WORK, INFO )
+ IMPLICIT NONE
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
@@ -178,14 +176,13 @@ SUBROUTINE DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
* .. Local Scalars ..
LOGICAL LEFT, NOTRAN
INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ
- DOUBLE PRECISION AII
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
- EXTERNAL DLARF, XERBLA
+ EXTERNAL XERBLA, DLARF1F
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
@@ -266,11 +263,9 @@ SUBROUTINE DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
*
* Apply H(i)
*
- AII = A( I, I )
- A( I, I ) = ONE
- CALL DLARF( SIDE, MI, NI, A( I, I ), 1, TAU( I ), C( IC, JC ),
+ CALL DLARF1F( SIDE, MI, NI, A( I, I ), 1, TAU( I ), C( IC,
+ $ JC ),
$ LDC, WORK )
- A( I, I ) = AII
10 CONTINUE
RETURN
*
diff --git a/lapack-netlib/SRC/dorml2.f b/lapack-netlib/SRC/dorml2.f
index a9ddd460d8..f5f8957b5b 100644
--- a/lapack-netlib/SRC/dorml2.f
+++ b/lapack-netlib/SRC/dorml2.f
@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
-*> \htmlonly
*> Download DORML2 + dependencies
*>
*> [TGZ]
@@ -13,7 +12,6 @@
*> [ZIP]
*>
*> [TXT]
-*> \endhtmlonly
*
* Definition:
* ===========
@@ -100,7 +98,6 @@
*> The i-th row must contain the vector which defines the
*> elementary reflector H(i), for i = 1,2,...,k, as returned by
*> DGELQF in the first k rows of its array argument A.
-*> A is modified by the routine but restored on exit.
*> \endverbatim
*>
*> \param[in] LDA
@@ -151,11 +148,12 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \ingroup doubleOTHERcomputational
+*> \ingroup unml2
*
* =====================================================================
SUBROUTINE DORML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
$ WORK, INFO )
+ IMPLICIT NONE
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
@@ -178,14 +176,13 @@ SUBROUTINE DORML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
* .. Local Scalars ..
LOGICAL LEFT, NOTRAN
INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ
- DOUBLE PRECISION AII
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
- EXTERNAL DLARF, XERBLA
+ EXTERNAL DLARF1F, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
@@ -266,11 +263,8 @@ SUBROUTINE DORML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
*
* Apply H(i)
*
- AII = A( I, I )
- A( I, I ) = ONE
- CALL DLARF( SIDE, MI, NI, A( I, I ), LDA, TAU( I ),
+ CALL DLARF1F( SIDE, MI, NI, A( I, I ), LDA, TAU( I ),
$ C( IC, JC ), LDC, WORK )
- A( I, I ) = AII
10 CONTINUE
RETURN
*
diff --git a/lapack-netlib/SRC/sgebd2.f b/lapack-netlib/SRC/sgebd2.f
index cb57ed6780..b49421b261 100644
--- a/lapack-netlib/SRC/sgebd2.f
+++ b/lapack-netlib/SRC/sgebd2.f
@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
-*> \htmlonly
*> Download SGEBD2 + dependencies
*>
*> [TGZ]
@@ -13,7 +12,6 @@
*> [ZIP]
*>
*> [TXT]
-*> \endhtmlonly
*
* Definition:
* ===========
@@ -132,7 +130,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \ingroup realGEcomputational
+*> \ingroup gebd2
*
*> \par Further Details:
* =====================
@@ -186,6 +184,7 @@
*>
* =====================================================================
SUBROUTINE SGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO )
+ IMPLICIT NONE
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
@@ -209,7 +208,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,14 +241,12 @@ 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
*
@@ -259,13 +256,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
@@ -278,33 +273,31 @@ SUBROUTINE SGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO )
*
* Generate elementary reflector G(i) to annihilate A(i,i+1:n)
*
- CALL SLARFG( N-I+1, A( I, I ), A( I, MIN( I+1, N ) ), LDA,
+ CALL SLARFG( N-I+1, A( I, I ), A( I, MIN( I+1, N ) ),
+ $ 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
*
* Generate elementary reflector H(i) to annihilate
* A(i+2:m,i)
*
- CALL SLARFG( M-I, A( I+1, I ), A( MIN( I+2, M ), I ), 1,
+ CALL SLARFG( M-I, A( I+1, I ), A( MIN( I+2, M ), I ),
+ $ 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/lapack-netlib/SRC/sgehd2.f b/lapack-netlib/SRC/sgehd2.f
index c7d8db19ec..bd3ff718b2 100644
--- a/lapack-netlib/SRC/sgehd2.f
+++ b/lapack-netlib/SRC/sgehd2.f
@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
-*> \htmlonly
*> Download SGEHD2 + dependencies
*>
*> [TGZ]
@@ -13,7 +12,6 @@
*> [ZIP]
*>
*> [TXT]
-*> \endhtmlonly
*
* Definition:
* ===========
@@ -106,7 +104,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \ingroup realGEcomputational
+*> \ingroup gehd2
*
*> \par Further Details:
* =====================
@@ -146,6 +144,7 @@
*>
* =====================================================================
SUBROUTINE SGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO )
+ IMPLICIT NONE
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
@@ -160,16 +159,11 @@ SUBROUTINE SGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO )
*
* =====================================================================
*
-* .. Parameters ..
- REAL ONE
- PARAMETER ( ONE = 1.0E+0 )
-* ..
* .. Local Scalars ..
INTEGER I
- REAL AII
* ..
* .. External Subroutines ..
- EXTERNAL SLARF, SLARFG, XERBLA
+ EXTERNAL SLARF1F, SLARFG, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
@@ -199,20 +193,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/lapack-netlib/SRC/sgelq2.f b/lapack-netlib/SRC/sgelq2.f
index 3e50beb13e..f0562432bf 100644
--- a/lapack-netlib/SRC/sgelq2.f
+++ b/lapack-netlib/SRC/sgelq2.f
@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
-*> \htmlonly
*> Download SGELQ2 + dependencies
*>
*> [TGZ]
@@ -13,7 +12,6 @@
*> [ZIP]
*>
*> [TXT]
-*> \endhtmlonly
*
* Definition:
* ===========
@@ -104,7 +102,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \ingroup realGEcomputational
+*> \ingroup gelq2
*
*> \par Further Details:
* =====================
@@ -126,6 +124,7 @@
*>
* =====================================================================
SUBROUTINE SGELQ2( M, N, A, LDA, TAU, WORK, INFO )
+ IMPLICIT NONE
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
@@ -140,16 +139,11 @@ SUBROUTINE SGELQ2( M, N, A, LDA, TAU, WORK, INFO )
*
* =====================================================================
*
-* .. Parameters ..
- REAL ONE
- PARAMETER ( ONE = 1.0E+0 )
-* ..
* .. Local Scalars ..
INTEGER I, K
- REAL AII
* ..
* .. External Subroutines ..
- EXTERNAL SLARF, SLARFG, XERBLA
+ EXTERNAL SLARF1F, SLARFG, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
@@ -183,11 +177,8 @@ 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/lapack-netlib/SRC/sgeql2.f b/lapack-netlib/SRC/sgeql2.f
index ea5ad6b82d..99d9f49ed4 100644
--- a/lapack-netlib/SRC/sgeql2.f
+++ b/lapack-netlib/SRC/sgeql2.f
@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
-*> \htmlonly
*> Download SGEQL2 + dependencies
*>
*> [TGZ]
@@ -13,7 +12,6 @@
*> [ZIP]
*>
*> [TXT]
-*> \endhtmlonly
*
* Definition:
* ===========
@@ -98,7 +96,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \ingroup realGEcomputational
+*> \ingroup geql2
*
*> \par Further Details:
* =====================
@@ -120,6 +118,7 @@
*>
* =====================================================================
SUBROUTINE SGEQL2( M, N, A, LDA, TAU, WORK, INFO )
+ IMPLICIT NONE
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
@@ -134,16 +133,11 @@ SUBROUTINE SGEQL2( M, N, A, LDA, TAU, WORK, INFO )
*
* =====================================================================
*
-* .. Parameters ..
- REAL ONE
- PARAMETER ( ONE = 1.0E+0 )
-* ..
* .. Local Scalars ..
INTEGER I, K
- REAL AII
* ..
* .. External Subroutines ..
- EXTERNAL SLARF, SLARFG, XERBLA
+ EXTERNAL SLARF1L, SLARFG, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
@@ -177,11 +171,8 @@ 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/lapack-netlib/SRC/sgeqp3rk.f b/lapack-netlib/SRC/sgeqp3rk.f
index d3a335b88e..9f0b76328d 100644
--- a/lapack-netlib/SRC/sgeqp3rk.f
+++ b/lapack-netlib/SRC/sgeqp3rk.f
@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
-*> \htmlonly
*> Download SGEQP3RK + dependencies
*>
*> [TGZ]
@@ -13,7 +12,6 @@
*> [ZIP]
*>
*> [TXT]
-*> \endhtmlonly
*
* Definition:
* ===========
@@ -546,27 +544,19 @@
*> C. H. Bischof, Math. and Comp. Sci. Div., Argonne National Lab, USA.
*> A BLAS-3 version of the QR factorization with column pivoting.
*> LAPACK Working Note 114
-*> \htmlonly
*> https://www.netlib.org/lapack/lawnspdf/lawn114.pdf
-*> \endhtmlonly
*> and in
*> SIAM J. Sci. Comput., 19(5):1486-1494, Sept. 1998.
-*> \htmlonly
*> https://doi.org/10.1137/S1064827595296732
-*> \endhtmlonly
*>
*> [2] A partial column norm updating strategy developed in 2006.
*> Z. Drmac and Z. Bujanovic, Dept. of Math., University of Zagreb, Croatia.
*> On the failure of rank revealing QR factorization software – a case study.
*> LAPACK Working Note 176.
-*> \htmlonly
*> http://www.netlib.org/lapack/lawnspdf/lawn176.pdf
-*> \endhtmlonly
*> and in
*> ACM Trans. Math. Softw. 35, 2, Article 12 (July 2008), 28 pages.
-*> \htmlonly
*> https://doi.org/10.1145/1377612.1377616
-*> \endhtmlonly
*
*> \par Contributors:
* ==================
@@ -671,7 +661,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 +677,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
@@ -887,7 +877,8 @@ SUBROUTINE SGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, A, LDA,
* Determine when to cross over from blocked to unblocked code.
* (for N less than NX, unblocked code should be used).
*
- NX = MAX( 0, ILAENV( IXOVER, 'SGEQP3RK', ' ', M, N, -1, -1 ))
+ NX = MAX( 0, ILAENV( IXOVER, 'SGEQP3RK', ' ', M, N, -1,
+ $ -1 ))
*
IF( NX.LT.MINMN ) THEN
*
diff --git a/lapack-netlib/SRC/sgeqr2.f b/lapack-netlib/SRC/sgeqr2.f
index 5eef521f27..0a9c3936df 100644
--- a/lapack-netlib/SRC/sgeqr2.f
+++ b/lapack-netlib/SRC/sgeqr2.f
@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
-*> \htmlonly
*> Download SGEQR2 + dependencies
*>
*> [TGZ]
@@ -13,7 +12,6 @@
*> [ZIP]
*>
*> [TXT]
-*> \endhtmlonly
*
* Definition:
* ===========
@@ -105,7 +103,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \ingroup realGEcomputational
+*> \ingroup geqr2
*
*> \par Further Details:
* =====================
@@ -127,6 +125,7 @@
*>
* =====================================================================
SUBROUTINE SGEQR2( M, N, A, LDA, TAU, WORK, INFO )
+ IMPLICIT NONE
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
@@ -141,16 +140,11 @@ SUBROUTINE SGEQR2( M, N, A, LDA, TAU, WORK, INFO )
*
* =====================================================================
*
-* .. Parameters ..
- REAL ONE
- PARAMETER ( ONE = 1.0E+0 )
-* ..
* .. Local Scalars ..
INTEGER I, K
- REAL AII
* ..
* .. External Subroutines ..
- EXTERNAL SLARF, SLARFG, XERBLA
+ EXTERNAL SLARF1F, SLARFG, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
@@ -184,11 +178,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/lapack-netlib/SRC/sgeqr2p.f b/lapack-netlib/SRC/sgeqr2p.f
index 0d270e9aa8..1e8c1f3e43 100644
--- a/lapack-netlib/SRC/sgeqr2p.f
+++ b/lapack-netlib/SRC/sgeqr2p.f
@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
-*> \htmlonly
*> Download SGEQR2P + dependencies
*>
*> [TGZ]
@@ -13,7 +12,6 @@
*> [ZIP]
*>
*> [TXT]
-*> \endhtmlonly
*
* Definition:
* ===========
@@ -107,7 +105,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \ingroup realGEcomputational
+*> \ingroup geqr2p
*
*> \par Further Details:
* =====================
@@ -131,6 +129,7 @@
*>
* =====================================================================
SUBROUTINE SGEQR2P( M, N, A, LDA, TAU, WORK, INFO )
+ IMPLICIT NONE
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
@@ -145,16 +144,11 @@ SUBROUTINE SGEQR2P( M, N, A, LDA, TAU, WORK, INFO )
*
* =====================================================================
*
-* .. Parameters ..
- REAL ONE
- PARAMETER ( ONE = 1.0E+0 )
-* ..
* .. Local Scalars ..
INTEGER I, K
- REAL AII
* ..
* .. External Subroutines ..
- EXTERNAL SLARF, SLARFGP, XERBLA
+ EXTERNAL SLARF1F, SLARFGP, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
@@ -188,11 +182,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/lapack-netlib/SRC/sgerq2.f b/lapack-netlib/SRC/sgerq2.f
index d86905c033..14c8cf0517 100644
--- a/lapack-netlib/SRC/sgerq2.f
+++ b/lapack-netlib/SRC/sgerq2.f
@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
-*> \htmlonly
*> Download SGERQ2 + dependencies
*>
*> [TGZ]
@@ -13,7 +12,6 @@
*> [ZIP]
*>
*> [TXT]
-*> \endhtmlonly
*
* Definition:
* ===========
@@ -98,7 +96,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \ingroup realGEcomputational
+*> \ingroup gerq2
*
*> \par Further Details:
* =====================
@@ -120,6 +118,7 @@
*>
* =====================================================================
SUBROUTINE SGERQ2( M, N, A, LDA, TAU, WORK, INFO )
+ IMPLICIT NONE
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
@@ -134,16 +133,11 @@ SUBROUTINE SGERQ2( M, N, A, LDA, TAU, WORK, INFO )
*
* =====================================================================
*
-* .. Parameters ..
- REAL ONE
- PARAMETER ( ONE = 1.0E+0 )
-* ..
* .. Local Scalars ..
INTEGER I, K
- REAL AII
* ..
* .. External Subroutines ..
- EXTERNAL SLARF, SLARFG, XERBLA
+ EXTERNAL SLARF1L, SLARFG, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
@@ -177,11 +171,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/lapack-netlib/SRC/slaqp2.f b/lapack-netlib/SRC/slaqp2.f
index 595fb8c340..530d1913d6 100644
--- a/lapack-netlib/SRC/slaqp2.f
+++ b/lapack-netlib/SRC/slaqp2.f
@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
-*> \htmlonly
*> Download SLAQP2 + dependencies
*>
*> [TGZ]
@@ -13,7 +12,6 @@
*> [ZIP]
*>
*> [TXT]
-*> \endhtmlonly
*
* Definition:
* ===========
@@ -122,7 +120,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \ingroup realOTHERauxiliary
+*> \ingroup laqp2
*
*> \par Contributors:
* ==================
@@ -139,13 +137,12 @@
*>
*> LAPACK Working Note 176
*
-*> \htmlonly
*> [PDF]
-*> \endhtmlonly
*
* =====================================================================
SUBROUTINE SLAQP2( M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2,
$ WORK )
+ IMPLICIT NONE
*
* -- LAPACK auxiliary routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
@@ -168,10 +165,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
@@ -208,7 +205,8 @@ SUBROUTINE SLAQP2( M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2,
* Generate elementary reflector H(i).
*
IF( OFFPI.LT.M ) THEN
- CALL SLARFG( M-OFFPI+1, A( OFFPI, I ), A( OFFPI+1, I ), 1,
+ CALL SLARFG( M-OFFPI+1, A( OFFPI, I ), A( OFFPI+1, I ),
+ $ 1,
$ TAU( I ) )
ELSE
CALL SLARFG( 1, A( M, I ), A( M, I ), 1, TAU( I ) )
@@ -218,11 +216,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/lapack-netlib/SRC/slaqp2rk.f b/lapack-netlib/SRC/slaqp2rk.f
index f88b0ce909..3825e25106 100644
--- a/lapack-netlib/SRC/slaqp2rk.f
+++ b/lapack-netlib/SRC/slaqp2rk.f
@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
-*> \htmlonly
*> Download SLAQP2RK + dependencies
*>
*> [TGZ]
@@ -13,7 +12,6 @@
*> [ZIP]
*>
*> [TXT]
-*> \endhtmlonly
*
* Definition:
* ===========
@@ -253,7 +251,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
*>
@@ -303,27 +301,19 @@
*> C. H. Bischof, Math. and Comp. Sci. Div., Argonne National Lab, USA.
*> A BLAS-3 version of the QR factorization with column pivoting.
*> LAPACK Working Note 114
-*> \htmlonly
*> https://www.netlib.org/lapack/lawnspdf/lawn114.pdf
-*> \endhtmlonly
*> and in
*> SIAM J. Sci. Comput., 19(5):1486-1494, Sept. 1998.
-*> \htmlonly
*> https://doi.org/10.1137/S1064827595296732
-*> \endhtmlonly
*>
*> [2] A partial column norm updating strategy developed in 2006.
*> Z. Drmac and Z. Bujanovic, Dept. of Math., University of Zagreb, Croatia.
*> On the failure of rank revealing QR factorization software – a case study.
*> LAPACK Working Note 176.
-*> \htmlonly
*> http://www.netlib.org/lapack/lawnspdf/lawn176.pdf
-*> \endhtmlonly
*> and in
*> ACM Trans. Math. Softw. 35, 2, Article 12 (July 2008), 28 pages.
-*> \htmlonly
*> https://doi.org/10.1145/1377612.1377616
-*> \endhtmlonly
*
*> \par Contributors:
* ==================
@@ -365,12 +355,12 @@ SUBROUTINE SLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL,
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
- INTEGER I, ITEMP, J, JMAXC2NRM, KK, KP, MINMNFACT,
- $ MINMNUPDT
- REAL AIKK, HUGEVAL, TEMP, TEMP2, TOL3Z
+ INTEGER I, ITEMP, J, JMAXC2NRM, KK, KP,
+ $ KBOUND, MINMNFACT, MINMNUPDT
+ REAL HUGEVAL, TEMP, TEMP2, TOL3Z
* ..
* .. External Subroutines ..
- EXTERNAL SLARF, SLARFG, SSWAP
+ EXTERNAL SLARF1F, SLARFG, SSWAP
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, SQRT
@@ -397,13 +387,13 @@ SUBROUTINE SLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL,
*
MINMNFACT = MIN( M-IOFFSET, N )
MINMNUPDT = MIN( M-IOFFSET, N+NRHS )
- KMAX = MIN( KMAX, MINMNFACT )
+ KBOUND = MIN( KMAX, MINMNFACT )
TOL3Z = SQRT( SLAMCH( 'Epsilon' ) )
HUGEVAL = SLAMCH( 'Overflow' )
*
* Compute the factorization, KK is the lomn loop index.
*
- DO KK = 1, KMAX
+ DO KK = 1, KBOUND
*
I = IOFFSET + KK
*
@@ -621,11 +611,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
@@ -676,7 +663,7 @@ SUBROUTINE SLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL,
* i.e. no condition was triggered to exit the routine.
* Set the number of factorized columns.
*
- K = KMAX
+ K = KBOUND
*
* We reached the end of the loop, i.e. all KMAX columns were
* factorized, we need to set MAXC2NRMK and RELMAXC2NRMK before
diff --git a/lapack-netlib/SRC/slaqr2.f b/lapack-netlib/SRC/slaqr2.f
index caf79fd1c0..9ee1f8b6e2 100644
--- a/lapack-netlib/SRC/slaqr2.f
+++ b/lapack-netlib/SRC/slaqr2.f
@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
-*> \htmlonly
*> Download SLAQR2 + dependencies
*>
*> [TGZ]
@@ -13,7 +12,6 @@
*> [ZIP]
*>
*> [TXT]
-*> \endhtmlonly
*
* Definition:
* ===========
@@ -272,9 +270,11 @@
*> University of Kansas, USA
*>
* =====================================================================
- SUBROUTINE SLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
+ SUBROUTINE SLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH,
+ $ ILOZ,
$ IHIZ, Z, LDZ, NS, ND, SR, SI, V, LDV, NH, T,
$ LDT, NV, WV, LDWV, WORK, LWORK )
+ IMPLICIT NONE
*
* -- LAPACK auxiliary routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
@@ -297,7 +297,7 @@ SUBROUTINE SLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
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,
@@ -309,8 +309,10 @@ SUBROUTINE SLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
EXTERNAL SLAMCH, SROUNDUP_LWORK
* ..
* .. External Subroutines ..
- EXTERNAL SCOPY, SGEHRD, SGEMM, SLACPY, SLAHQR,
- $ SLANV2, SLARF, SLARFG, SLASET, SORMHR, STREXC
+ EXTERNAL SCOPY, SGEHRD, SGEMM, SLACPY,
+ $ SLAHQR,
+ $ SLANV2, SLARF1L, SLARFG, SLASET, SORMHR,
+ $ STREXC
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, INT, MAX, MIN, REAL, SQRT
@@ -331,7 +333,8 @@ SUBROUTINE SLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
*
* ==== Workspace query call to SORMHR ====
*
- CALL SORMHR( 'R', 'N', JW, JW, 1, JW-1, T, LDT, WORK, V, LDV,
+ CALL SORMHR( 'R', 'N', JW, JW, 1, JW-1, T, LDT, WORK, V,
+ $ LDV,
$ WORK, -1, INFO )
LWK2 = INT( WORK( 1 ) )
*
@@ -401,7 +404,8 @@ SUBROUTINE SLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
* . here and there to keep track.) ====
*
CALL SLACPY( 'U', JW, JW, H( KWTOP, KWTOP ), LDH, T, LDT )
- CALL SCOPY( JW-1, H( KWTOP+1, KWTOP ), LDH+1, T( 2, 1 ), LDT+1 )
+ CALL SCOPY( JW-1, H( KWTOP+1, KWTOP ), LDH+1, T( 2, 1 ),
+ $ LDT+1 )
*
CALL SLASET( 'A', JW, JW, ZERO, ONE, V, LDV )
CALL SLAHQR( .true., .true., JW, 1, JW, T, LDT, SR( KWTOP ),
@@ -448,7 +452,8 @@ SUBROUTINE SLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
* . (STREXC can not fail in this case.) ====
*
IFST = NS
- CALL STREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, WORK,
+ CALL STREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST,
+ $ WORK,
$ INFO )
ILST = ILST + 1
END IF
@@ -473,7 +478,8 @@ SUBROUTINE SLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
* . ILST in case of a rare exchange failure. ====
*
IFST = NS
- CALL STREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, WORK,
+ CALL STREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST,
+ $ WORK,
$ INFO )
ILST = ILST + 2
END IF
@@ -535,7 +541,8 @@ SUBROUTINE SLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
SORTED = .false.
IFST = I
ILST = K
- CALL STREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, WORK,
+ CALL STREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST,
+ $ WORK,
$ INFO )
IF( INFO.EQ.0 ) THEN
I = ILST
@@ -588,18 +595,17 @@ SUBROUTINE SLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
* ==== 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 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 )
@@ -617,7 +623,8 @@ SUBROUTINE SLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
* . H and Z, if requested. ====
*
IF( NS.GT.1 .AND. S.NE.ZERO )
- $ CALL SORMHR( 'R', 'N', JW, NS, 1, NS, T, LDT, WORK, V, LDV,
+ $ CALL SORMHR( 'R', 'N', JW, NS, 1, NS, T, LDT, WORK, V,
+ $ LDV,
$ WORK( JW+1 ), LWORK-JW, INFO )
*
* ==== Update vertical slab in H ====
@@ -631,7 +638,8 @@ SUBROUTINE SLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
KLN = MIN( NV, KWTOP-KROW )
CALL SGEMM( 'N', 'N', KLN, JW, JW, ONE, H( KROW, KWTOP ),
$ LDH, V, LDV, ZERO, WV, LDWV )
- CALL SLACPY( 'A', KLN, JW, WV, LDWV, H( KROW, KWTOP ), LDH )
+ CALL SLACPY( 'A', KLN, JW, WV, LDWV, H( KROW, KWTOP ),
+ $ LDH )
70 CONTINUE
*
* ==== Update horizontal slab in H ====
@@ -651,7 +659,8 @@ SUBROUTINE SLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
IF( WANTZ ) THEN
DO 90 KROW = ILOZ, IHIZ, NV
KLN = MIN( NV, IHIZ-KROW+1 )
- CALL SGEMM( 'N', 'N', KLN, JW, JW, ONE, Z( KROW, KWTOP ),
+ CALL SGEMM( 'N', 'N', KLN, JW, JW, ONE, Z( KROW,
+ $ KWTOP ),
$ LDZ, V, LDV, ZERO, WV, LDWV )
CALL SLACPY( 'A', KLN, JW, WV, LDWV, Z( KROW, KWTOP ),
$ LDZ )
diff --git a/lapack-netlib/SRC/slaqr3.f b/lapack-netlib/SRC/slaqr3.f
index d3ffb0f969..f9f8090a3a 100644
--- a/lapack-netlib/SRC/slaqr3.f
+++ b/lapack-netlib/SRC/slaqr3.f
@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
-*> \htmlonly
*> Download SLAQR3 + dependencies
*>
*> [TGZ]
@@ -13,7 +12,6 @@
*> [ZIP]
*>
*> [TXT]
-*> \endhtmlonly
*
* Definition:
* ===========
@@ -269,9 +267,11 @@
*> University of Kansas, USA
*>
* =====================================================================
- SUBROUTINE SLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
+ SUBROUTINE SLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH,
+ $ ILOZ,
$ IHIZ, Z, LDZ, NS, ND, SR, SI, V, LDV, NH, T,
$ LDT, NV, WV, LDWV, WORK, LWORK )
+ IMPLICIT NONE
*
* -- LAPACK auxiliary routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
@@ -294,7 +294,7 @@ SUBROUTINE SLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
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, LWK3,
@@ -307,8 +307,10 @@ SUBROUTINE SLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
EXTERNAL SLAMCH, SROUNDUP_LWORK, ILAENV
* ..
* .. External Subroutines ..
- EXTERNAL SCOPY, SGEHRD, SGEMM, SLACPY, SLAHQR, SLANV2,
- $ SLAQR4, SLARF, SLARFG, SLASET, SORMHR, STREXC
+ EXTERNAL SCOPY, SGEHRD, SGEMM, SLACPY, SLAHQR,
+ $ SLANV2,
+ $ SLAQR4, SLARF1F, SLARFG, SLASET, SORMHR,
+ $ STREXC
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, INT, MAX, MIN, REAL, SQRT
@@ -329,13 +331,15 @@ SUBROUTINE SLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
*
* ==== Workspace query call to SORMHR ====
*
- CALL SORMHR( 'R', 'N', JW, JW, 1, JW-1, T, LDT, WORK, V, LDV,
+ CALL SORMHR( 'R', 'N', JW, JW, 1, JW-1, T, LDT, WORK, V,
+ $ LDV,
$ WORK, -1, INFO )
LWK2 = INT( WORK( 1 ) )
*
* ==== Workspace query call to SLAQR4 ====
*
- CALL SLAQR4( .true., .true., JW, 1, JW, T, LDT, SR, SI, 1, JW,
+ CALL SLAQR4( .true., .true., JW, 1, JW, T, LDT, SR, SI, 1,
+ $ JW,
$ V, LDV, WORK, -1, INFQR )
LWK3 = INT( WORK( 1 ) )
*
@@ -405,7 +409,8 @@ SUBROUTINE SLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
* . here and there to keep track.) ====
*
CALL SLACPY( 'U', JW, JW, H( KWTOP, KWTOP ), LDH, T, LDT )
- CALL SCOPY( JW-1, H( KWTOP+1, KWTOP ), LDH+1, T( 2, 1 ), LDT+1 )
+ CALL SCOPY( JW-1, H( KWTOP+1, KWTOP ), LDH+1, T( 2, 1 ),
+ $ LDT+1 )
*
CALL SLASET( 'A', JW, JW, ZERO, ONE, V, LDV )
NMIN = ILAENV( 12, 'SLAQR3', 'SV', JW, 1, JW, LWORK )
@@ -458,7 +463,8 @@ SUBROUTINE SLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
* . (STREXC can not fail in this case.) ====
*
IFST = NS
- CALL STREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, WORK,
+ CALL STREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST,
+ $ WORK,
$ INFO )
ILST = ILST + 1
END IF
@@ -483,7 +489,8 @@ SUBROUTINE SLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
* . ILST in case of a rare exchange failure. ====
*
IFST = NS
- CALL STREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, WORK,
+ CALL STREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST,
+ $ WORK,
$ INFO )
ILST = ILST + 2
END IF
@@ -545,7 +552,8 @@ SUBROUTINE SLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
SORTED = .false.
IFST = I
ILST = K
- CALL STREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, WORK,
+ CALL STREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST,
+ $ WORK,
$ INFO )
IF( INFO.EQ.0 ) THEN
I = ILST
@@ -598,18 +606,17 @@ SUBROUTINE SLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
* ==== 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 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 )
@@ -627,7 +634,8 @@ SUBROUTINE SLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
* . H and Z, if requested. ====
*
IF( NS.GT.1 .AND. S.NE.ZERO )
- $ CALL SORMHR( 'R', 'N', JW, NS, 1, NS, T, LDT, WORK, V, LDV,
+ $ CALL SORMHR( 'R', 'N', JW, NS, 1, NS, T, LDT, WORK, V,
+ $ LDV,
$ WORK( JW+1 ), LWORK-JW, INFO )
*
* ==== Update vertical slab in H ====
@@ -641,7 +649,8 @@ SUBROUTINE SLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
KLN = MIN( NV, KWTOP-KROW )
CALL SGEMM( 'N', 'N', KLN, JW, JW, ONE, H( KROW, KWTOP ),
$ LDH, V, LDV, ZERO, WV, LDWV )
- CALL SLACPY( 'A', KLN, JW, WV, LDWV, H( KROW, KWTOP ), LDH )
+ CALL SLACPY( 'A', KLN, JW, WV, LDWV, H( KROW, KWTOP ),
+ $ LDH )
70 CONTINUE
*
* ==== Update horizontal slab in H ====
@@ -661,7 +670,8 @@ SUBROUTINE SLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
IF( WANTZ ) THEN
DO 90 KROW = ILOZ, IHIZ, NV
KLN = MIN( NV, IHIZ-KROW+1 )
- CALL SGEMM( 'N', 'N', KLN, JW, JW, ONE, Z( KROW, KWTOP ),
+ CALL SGEMM( 'N', 'N', KLN, JW, JW, ONE, Z( KROW,
+ $ KWTOP ),
$ LDZ, V, LDV, ZERO, WV, LDWV )
CALL SLACPY( 'A', KLN, JW, WV, LDWV, Z( KROW, KWTOP ),
$ LDZ )
diff --git a/lapack-netlib/SRC/slarf1f.c b/lapack-netlib/SRC/slarf1f.c
new file mode 100644
index 0000000000..498201ffa4
--- /dev/null
+++ b/lapack-netlib/SRC/slarf1f.c
@@ -0,0 +1,528 @@
+#include
+#include
+#include
+#include
+#include
+#ifdef complex
+#undef complex
+#endif
+#ifdef I
+#undef I
+#endif
+
+#if defined(_WIN64)
+typedef long long BLASLONG;
+typedef unsigned long long BLASULONG;
+#else
+typedef long BLASLONG;
+typedef unsigned long BLASULONG;
+#endif
+
+#ifdef LAPACK_ILP64
+typedef BLASLONG blasint;
+#if defined(_WIN64)
+#define blasabs(x) llabs(x)
+#else
+#define blasabs(x) labs(x)
+#endif
+#else
+typedef int blasint;
+#define blasabs(x) abs(x)
+#endif
+
+typedef blasint integer;
+
+typedef unsigned int uinteger;
+typedef char *address;
+typedef short int shortint;
+typedef float real;
+typedef double doublereal;
+typedef struct { real r, i; } complex;
+typedef struct { doublereal r, i; } doublecomplex;
+#ifdef _MSC_VER
+static inline _Fcomplex Cf(complex *z) {_Fcomplex zz={z->r , z->i}; return zz;}
+static inline _Dcomplex Cd(doublecomplex *z) {_Dcomplex zz={z->r , z->i};return zz;}
+static inline _Fcomplex * _pCf(complex *z) {return (_Fcomplex*)z;}
+static inline _Dcomplex * _pCd(doublecomplex *z) {return (_Dcomplex*)z;}
+#else
+static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;}
+static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;}
+static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;}
+static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;}
+#endif
+#define pCf(z) (*_pCf(z))
+#define pCd(z) (*_pCd(z))
+typedef int logical;
+typedef short int shortlogical;
+typedef char logical1;
+typedef char integer1;
+
+#define TRUE_ (1)
+#define FALSE_ (0)
+
+/* Extern is for use with -E */
+#ifndef Extern
+#define Extern extern
+#endif
+
+/* I/O stuff */
+
+typedef int flag;
+typedef int ftnlen;
+typedef int ftnint;
+
+/*external read, write*/
+typedef struct
+{ flag cierr;
+ ftnint ciunit;
+ flag ciend;
+ char *cifmt;
+ ftnint cirec;
+} cilist;
+
+/*internal read, write*/
+typedef struct
+{ flag icierr;
+ char *iciunit;
+ flag iciend;
+ char *icifmt;
+ ftnint icirlen;
+ ftnint icirnum;
+} icilist;
+
+/*open*/
+typedef struct
+{ flag oerr;
+ ftnint ounit;
+ char *ofnm;
+ ftnlen ofnmlen;
+ char *osta;
+ char *oacc;
+ char *ofm;
+ ftnint orl;
+ char *oblnk;
+} olist;
+
+/*close*/
+typedef struct
+{ flag cerr;
+ ftnint cunit;
+ char *csta;
+} cllist;
+
+/*rewind, backspace, endfile*/
+typedef struct
+{ flag aerr;
+ ftnint aunit;
+} alist;
+
+/* inquire */
+typedef struct
+{ flag inerr;
+ ftnint inunit;
+ char *infile;
+ ftnlen infilen;
+ ftnint *inex; /*parameters in standard's order*/
+ ftnint *inopen;
+ ftnint *innum;
+ ftnint *innamed;
+ char *inname;
+ ftnlen innamlen;
+ char *inacc;
+ ftnlen inacclen;
+ char *inseq;
+ ftnlen inseqlen;
+ char *indir;
+ ftnlen indirlen;
+ char *infmt;
+ ftnlen infmtlen;
+ char *inform;
+ ftnint informlen;
+ char *inunf;
+ ftnlen inunflen;
+ ftnint *inrecl;
+ ftnint *innrec;
+ char *inblank;
+ ftnlen inblanklen;
+} inlist;
+
+#define VOID void
+
+union Multitype { /* for multiple entry points */
+ integer1 g;
+ shortint h;
+ integer i;
+ /* longint j; */
+ real r;
+ doublereal d;
+ complex c;
+ doublecomplex z;
+ };
+
+typedef union Multitype Multitype;
+
+struct Vardesc { /* for Namelist */
+ char *name;
+ char *addr;
+ ftnlen *dims;
+ int type;
+ };
+typedef struct Vardesc Vardesc;
+
+struct Namelist {
+ char *name;
+ Vardesc **vars;
+ int nvars;
+ };
+typedef struct Namelist Namelist;
+
+#define abs(x) ((x) >= 0 ? (x) : -(x))
+#define dabs(x) (fabs(x))
+#define f2cmin(a,b) ((a) <= (b) ? (a) : (b))
+#define f2cmax(a,b) ((a) >= (b) ? (a) : (b))
+#define dmin(a,b) (f2cmin(a,b))
+#define dmax(a,b) (f2cmax(a,b))
+#define bit_test(a,b) ((a) >> (b) & 1)
+#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b)))
+#define bit_set(a,b) ((a) | ((uinteger)1 << (b)))
+
+#define abort_() { sig_die("Fortran abort routine called", 1); }
+#define c_abs(z) (cabsf(Cf(z)))
+#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); }
+#ifdef _MSC_VER
+#define c_div(c, a, b) {Cf(c)._Val[0] = (Cf(a)._Val[0]/Cf(b)._Val[0]); Cf(c)._Val[1]=(Cf(a)._Val[1]/Cf(b)._Val[1]);}
+#define z_div(c, a, b) {Cd(c)._Val[0] = (Cd(a)._Val[0]/Cd(b)._Val[0]); Cd(c)._Val[1]=(Cd(a)._Val[1]/Cd(b)._Val[1]);}
+#else
+#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);}
+#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);}
+#endif
+#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));}
+#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));}
+#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));}
+//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));}
+#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));}
+#define d_abs(x) (fabs(*(x)))
+#define d_acos(x) (acos(*(x)))
+#define d_asin(x) (asin(*(x)))
+#define d_atan(x) (atan(*(x)))
+#define d_atn2(x, y) (atan2(*(x),*(y)))
+#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); }
+#define r_cnjg(R, Z) { pCf(R) = conjf(Cf(Z)); }
+#define d_cos(x) (cos(*(x)))
+#define d_cosh(x) (cosh(*(x)))
+#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 )
+#define d_exp(x) (exp(*(x)))
+#define d_imag(z) (cimag(Cd(z)))
+#define r_imag(z) (cimagf(Cf(z)))
+#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define d_log(x) (log(*(x)))
+#define d_mod(x, y) (fmod(*(x), *(y)))
+#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x)))
+#define d_nint(x) u_nint(*(x))
+#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a)))
+#define d_sign(a,b) u_sign(*(a),*(b))
+#define r_sign(a,b) u_sign(*(a),*(b))
+#define d_sin(x) (sin(*(x)))
+#define d_sinh(x) (sinh(*(x)))
+#define d_sqrt(x) (sqrt(*(x)))
+#define d_tan(x) (tan(*(x)))
+#define d_tanh(x) (tanh(*(x)))
+#define i_abs(x) abs(*(x))
+#define i_dnnt(x) ((integer)u_nint(*(x)))
+#define i_len(s, n) (n)
+#define i_nint(x) ((integer)u_nint(*(x)))
+#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b)))
+#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; }
+#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d))))
+#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
+#define sig_die(s, kill) { exit(1); }
+#define s_stop(s, n) {exit(0);}
+#define z_abs(z) (cabs(Cd(z)))
+#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
+#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
+
+/* procedure parameter types for -A and -C++ */
+
+#define F2C_proc_par_types 1
+#ifdef __cplusplus
+typedef logical (*L_fp)(...);
+#else
+typedef logical (*L_fp)();
+#endif
+
+/* Table of constant values */
+
+static real c_b4 = 1.f;
+static real c_b5 = 0.f;
+static integer c__1 = 1;
+
+/* > \brief \b SLARF1F applies an elementary reflector to a general rectangular */
+/* matrix assuming v(1) = 1. */
+
+/* =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/* http://www.netlib.org/lapack/explore-html/ */
+
+/* > Download SLARF1F + dependencies */
+/* > */
+/* > [TGZ] */
+/* > */
+/* > [ZIP] */
+/* > */
+/* > [TXT] */
+
+/* Definition: */
+/* =========== */
+
+/* SUBROUTINE SLARF1F( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) */
+
+/* CHARACTER SIDE */
+/* INTEGER INCV, LDC, M, N */
+/* REAL TAU */
+/* REAL C( LDC, * ), V( * ), WORK( * ) */
+
+
+/* > \par Purpose: */
+/* ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > SLARF1F applies a real elementary reflector H to a real m by n matrix */
+/* > C, from either the left or the right. H is represented in the form */
+/* > */
+/* > H = I - tau * v * v**T */
+/* > */
+/* > where tau is a real scalar and v is a real vector assuming v(1) = 1. */
+/* > */
+/* > If tau = 0, then H is taken to be the unit matrix. */
+/* > \endverbatim */
+
+/* Arguments: */
+/* ========== */
+
+/* > \param[in] SIDE */
+/* > \verbatim */
+/* > SIDE is CHARACTER*1 */
+/* > = 'L': form H * C */
+/* > = 'R': form C * H */
+/* > \endverbatim */
+/* > */
+/* > \param[in] M */
+/* > \verbatim */
+/* > M is INTEGER */
+/* > The number of rows of the matrix C. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] N */
+/* > \verbatim */
+/* > N is INTEGER */
+/* > The number of columns of the matrix C. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] V */
+/* > \verbatim */
+/* > V is REAL array, dimension */
+/* > (1 + (M-1)*abs(INCV)) if SIDE = 'L' */
+/* > or (1 + (N-1)*abs(INCV)) if SIDE = 'R' */
+/* > The vector v in the representation of H. V is not used if */
+/* > TAU = 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] INCV */
+/* > \verbatim */
+/* > INCV is INTEGER */
+/* > The increment between elements of v. INCV <> 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] TAU */
+/* > \verbatim */
+/* > TAU is REAL */
+/* > The value tau in the representation of H. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] C */
+/* > \verbatim */
+/* > C is REAL array, dimension (LDC,N) */
+/* > On entry, the m by n matrix C. */
+/* > On exit, C is overwritten by the matrix H * C if SIDE = 'L', */
+/* > or C * H if SIDE = 'R'. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDC */
+/* > \verbatim */
+/* > LDC is INTEGER */
+/* > The leading dimension of the array C. LDC >= f2cmax(1,M). */
+/* > \endverbatim */
+/* > */
+/* > \param[out] WORK */
+/* > \verbatim */
+/* > WORK is REAL array, dimension */
+/* > (N) if SIDE = 'L' */
+/* > or (M) if SIDE = 'R' */
+/* > \endverbatim */
+
+/* Authors: */
+/* ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \ingroup larf1f */
+
+/* ===================================================================== */
+/* Subroutine */ int slarf1f_(char *side, integer *m, integer *n, real *v,
+ integer *incv, real *tau, real *c__, integer *ldc, real *work)
+{
+ /* System generated locals */
+ integer c_dim1, c_offset, i__1;
+ real r__1;
+
+ /* Local variables */
+ integer i__;
+ logical applyleft;
+ extern /* Subroutine */ int sger_(integer *, integer *, real *, real *,
+ integer *, real *, integer *, real *, integer *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+ integer lastc;
+ extern /* Subroutine */ int sgemv_(char *, integer *, integer *, real *,
+ real *, integer *, real *, integer *, real *, real *, integer *);
+ integer lastv;
+ extern /* Subroutine */ int saxpy_(integer *, real *, real *, integer *,
+ real *, integer *);
+ extern integer ilaslc_(integer *, integer *, real *, integer *), ilaslr_(
+ integer *, integer *, real *, integer *);
+
+
+/* -- LAPACK auxiliary routine -- */
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+
+
+/* ===================================================================== */
+
+
+ /* Parameter adjustments */
+ --v;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --work;
+
+ /* Function Body */
+ applyleft = lsame_(side, "L");
+ lastv = 1;
+ lastc = 0;
+ if (*tau != 0.f) {
+/* Set up variables for scanning V. LASTV begins pointing to the end */
+/* of V up to V(1). */
+ if (applyleft) {
+ lastv = *m;
+ } else {
+ lastv = *n;
+ }
+ if (*incv > 0) {
+ i__ = (lastv - 1) * *incv + 1;
+ } else {
+ i__ = 1;
+ }
+/* Look for the last non-zero row in V. */
+ while(lastv > 1 && v[i__] == 0.f) {
+ --lastv;
+ i__ -= *incv;
+ }
+ if (applyleft) {
+/* Scan for the last non-zero column in C(1:lastv,:). */
+ lastc = ilaslc_(&lastv, n, &c__[c_offset], ldc);
+ } else {
+/* Scan for the last non-zero row in C(:,1:lastv). */
+ lastc = ilaslr_(m, &lastv, &c__[c_offset], ldc);
+ }
+ }
+ if (lastc == 0) {
+ return 0;
+ }
+ if (applyleft) {
+
+/* Form H * C */
+
+ if (lastv == 1) {
+
+/* C(1,1:lastc) := ( 1 - tau ) * C(1,1:lastc) */
+
+ r__1 = 1.f - *tau;
+ sscal_(&lastc, &r__1, &c__[c_offset], ldc);
+ } else {
+
+/* w(1:lastc,1) := C(2:lastv,1:lastc)**T * v(2:lastv,1) */
+
+ i__1 = lastv - 1;
+ sgemv_("Transpose", &i__1, &lastc, &c_b4, &c__[c_dim1 + 2], ldc, &
+ v[*incv + 1], incv, &c_b5, &work[1], &c__1);
+
+/* w(1:lastc,1) += v(1,1) * C(1,1:lastc)**T */
+
+ saxpy_(&lastc, &c_b4, &c__[c_offset], ldc, &work[1], &c__1);
+
+/* C(1, 1:lastc) += - tau * v(1,1) * w(1:lastc,1)**T */
+
+ r__1 = -(*tau);
+ saxpy_(&lastc, &r__1, &work[1], &c__1, &c__[c_offset], ldc);
+
+/* C(2:lastv,1:lastc) += - tau * v(2:lastv,1) * w(1:lastc,1)**T */
+
+ i__1 = lastv - 1;
+ r__1 = -(*tau);
+ sger_(&i__1, &lastc, &r__1, &v[*incv + 1], incv, &work[1], &c__1,
+ &c__[c_dim1 + 2], ldc);
+ }
+ } else {
+
+/* Form C * H */
+
+ if (lastv == 1) {
+
+/* C(1:lastc,1) := ( 1 - tau ) * C(1:lastc,1) */
+
+ r__1 = 1.f - *tau;
+ sscal_(&lastc, &r__1, &c__[c_offset], &c__1);
+ } else {
+
+/* w(1:lastc,1) := C(1:lastc,2:lastv) * v(2:lastv,1) */
+
+ i__1 = lastv - 1;
+ sgemv_("No transpose", &lastc, &i__1, &c_b4, &c__[(c_dim1 << 1) +
+ 1], ldc, &v[*incv + 1], incv, &c_b5, &work[1], &c__1);
+
+/* w(1:lastc,1) += v(1,1) * C(1:lastc,1) */
+
+ saxpy_(&lastc, &c_b4, &c__[c_offset], &c__1, &work[1], &c__1);
+
+/* C(1:lastc,1) += - tau * v(1,1) * w(1:lastc,1) */
+
+ r__1 = -(*tau);
+ saxpy_(&lastc, &r__1, &work[1], &c__1, &c__[c_offset], &c__1);
+
+/* C(1:lastc,2:lastv) += - tau * w(1:lastc,1) * v(2:lastv)**T */
+
+ i__1 = lastv - 1;
+ r__1 = -(*tau);
+ sger_(&lastc, &i__1, &r__1, &work[1], &c__1, &v[*incv + 1], incv,
+ &c__[(c_dim1 << 1) + 1], ldc);
+ }
+ }
+ return 0;
+
+/* End of SLARF1F */
+
+} /* slarf1f_ */
+
diff --git a/lapack-netlib/SRC/slarf1f.f b/lapack-netlib/SRC/slarf1f.f
new file mode 100644
index 0000000000..d0c015eacf
--- /dev/null
+++ b/lapack-netlib/SRC/slarf1f.f
@@ -0,0 +1,254 @@
+*> \brief \b SLARF1F applies an elementary reflector to a general rectangular
+* matrix assuming v(1) = 1.
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> Download SLARF1F + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE SLARF1F( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )
+*
+* .. Scalar Arguments ..
+* CHARACTER SIDE
+* INTEGER INCV, LDC, M, N
+* REAL TAU
+* ..
+* .. Array Arguments ..
+* REAL C( LDC, * ), V( * ), WORK( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> SLARF1F applies a real elementary reflector H to a real m by n matrix
+*> C, from either the left or the right. H is represented in the form
+*>
+*> H = I - tau * v * v**T
+*>
+*> where tau is a real scalar and v is a real vector assuming v(1) = 1.
+*>
+*> If tau = 0, then H is taken to be the unit matrix.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] SIDE
+*> \verbatim
+*> SIDE is CHARACTER*1
+*> = 'L': form H * C
+*> = 'R': form C * H
+*> \endverbatim
+*>
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows of the matrix C.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of columns of the matrix C.
+*> \endverbatim
+*>
+*> \param[in] V
+*> \verbatim
+*> V is REAL array, dimension
+*> (1 + (M-1)*abs(INCV)) if SIDE = 'L'
+*> or (1 + (N-1)*abs(INCV)) if SIDE = 'R'
+*> The vector v in the representation of H. V is not used if
+*> TAU = 0.
+*> \endverbatim
+*>
+*> \param[in] INCV
+*> \verbatim
+*> INCV is INTEGER
+*> The increment between elements of v. INCV <> 0.
+*> \endverbatim
+*>
+*> \param[in] TAU
+*> \verbatim
+*> TAU is REAL
+*> The value tau in the representation of H.
+*> \endverbatim
+*>
+*> \param[in,out] C
+*> \verbatim
+*> C is REAL array, dimension (LDC,N)
+*> On entry, the m by n matrix C.
+*> On exit, C is overwritten by the matrix H * C if SIDE = 'L',
+*> or C * H if SIDE = 'R'.
+*> \endverbatim
+*>
+*> \param[in] LDC
+*> \verbatim
+*> LDC is INTEGER
+*> The leading dimension of the array C. LDC >= max(1,M).
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is REAL array, dimension
+*> (N) if SIDE = 'L'
+*> or (M) if SIDE = 'R'
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \ingroup larf1f
+*
+* =====================================================================
+ SUBROUTINE SLARF1F( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )
+ IMPLICIT NONE
+*
+* -- LAPACK auxiliary routine --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+*
+* .. Scalar Arguments ..
+ CHARACTER SIDE
+ INTEGER INCV, LDC, M, N
+ REAL TAU
+* ..
+* .. Array Arguments ..
+ REAL C( LDC, * ), V( * ), WORK( * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE, ZERO
+ PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL APPLYLEFT
+ INTEGER I, LASTV, LASTC
+* ..
+* .. External Subroutines ..
+ EXTERNAL SGEMV, SGER, SAXPY, SSCAL
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILASLR, ILASLC
+ EXTERNAL LSAME, ILASLR, ILASLC
+* ..
+* .. Executable Statements ..
+*
+ APPLYLEFT = LSAME( SIDE, 'L' )
+ LASTV = 1
+ LASTC = 0
+ IF( TAU.NE.ZERO ) THEN
+! Set up variables for scanning V. LASTV begins pointing to the end
+! of V up to V(1).
+ IF( APPLYLEFT ) THEN
+ LASTV = M
+ ELSE
+ LASTV = N
+ END IF
+ IF( INCV.GT.0 ) THEN
+ I = 1 + (LASTV-1) * INCV
+ ELSE
+ I = 1
+ END IF
+! Look for the last non-zero row in V.
+ DO WHILE( LASTV.GT.1 .AND. V( I ).EQ.ZERO )
+ LASTV = LASTV - 1
+ I = I - INCV
+ END DO
+ IF( APPLYLEFT ) THEN
+! Scan for the last non-zero column in C(1:lastv,:).
+ LASTC = ILASLC(LASTV, N, C, LDC)
+ ELSE
+! Scan for the last non-zero row in C(:,1:lastv).
+ LASTC = ILASLR(M, LASTV, C, LDC)
+ END IF
+ END IF
+ IF( LASTC.EQ.0 ) THEN
+ RETURN
+ END IF
+ IF( APPLYLEFT ) THEN
+*
+* Form H * C
+*
+ IF( LASTV.EQ.1 ) THEN
+*
+* C(1,1:lastc) := ( 1 - tau ) * C(1,1:lastc)
+*
+ CALL SSCAL( LASTC, ONE - TAU, C, LDC )
+ ELSE
+*
+* w(1:lastc,1) := C(2:lastv,1:lastc)**T * v(2:lastv,1)
+*
+ CALL SGEMV( 'Transpose', LASTV - 1, LASTC, ONE, C( 2, 1 ),
+ $ LDC, V( 1 + INCV ), INCV, ZERO, WORK, 1 )
+*
+* w(1:lastc,1) += v(1,1) * C(1,1:lastc)**T
+*
+ CALL SAXPY( LASTC, ONE, C, LDC, WORK, 1 )
+*
+* C(1, 1:lastc) += - tau * v(1,1) * w(1:lastc,1)**T
+*
+ CALL SAXPY( LASTC, -TAU, WORK, 1, C, LDC )
+*
+* C(2:lastv,1:lastc) += - tau * v(2:lastv,1) * w(1:lastc,1)**T
+*
+ CALL SGER( LASTV - 1, LASTC, -TAU, V( 1 + INCV ), INCV,
+ $ WORK, 1, C( 2, 1 ), LDC )
+ END IF
+ ELSE
+*
+* Form C * H
+*
+ IF( LASTV.EQ.1 ) THEN
+*
+* C(1:lastc,1) := ( 1 - tau ) * C(1:lastc,1)
+*
+ CALL SSCAL( LASTC, ONE - TAU, C, 1 )
+ ELSE
+*
+* w(1:lastc,1) := C(1:lastc,2:lastv) * v(2:lastv,1)
+*
+ CALL SGEMV( 'No transpose', LASTC, LASTV - 1, ONE,
+ $ C( 1, 2 ), LDC, V( 1 + INCV ), INCV, ZERO,
+ $ WORK, 1 )
+*
+* w(1:lastc,1) += v(1,1) * C(1:lastc,1)
+*
+ CALL SAXPY( LASTC, ONE, C, 1, WORK, 1 )
+*
+* C(1:lastc,1) += - tau * v(1,1) * w(1:lastc,1)
+*
+ CALL SAXPY( LASTC, -TAU, WORK, 1, C, 1 )
+*
+* C(1:lastc,2:lastv) += - tau * w(1:lastc,1) * v(2:lastv)**T
+*
+ CALL SGER( LASTC, LASTV - 1, -TAU, WORK, 1,
+ $ V( 1 + INCV ), INCV, C( 1, 2 ), LDC )
+ END IF
+ END IF
+ RETURN
+*
+* End of SLARF1F
+*
+ END
diff --git a/lapack-netlib/SRC/slarf1l.c b/lapack-netlib/SRC/slarf1l.c
new file mode 100644
index 0000000000..ce7a8c4f85
--- /dev/null
+++ b/lapack-netlib/SRC/slarf1l.c
@@ -0,0 +1,530 @@
+#include
+#include
+#include
+#include
+#include
+#ifdef complex
+#undef complex
+#endif
+#ifdef I
+#undef I
+#endif
+
+#if defined(_WIN64)
+typedef long long BLASLONG;
+typedef unsigned long long BLASULONG;
+#else
+typedef long BLASLONG;
+typedef unsigned long BLASULONG;
+#endif
+
+#ifdef LAPACK_ILP64
+typedef BLASLONG blasint;
+#if defined(_WIN64)
+#define blasabs(x) llabs(x)
+#else
+#define blasabs(x) labs(x)
+#endif
+#else
+typedef int blasint;
+#define blasabs(x) abs(x)
+#endif
+
+typedef blasint integer;
+
+typedef unsigned int uinteger;
+typedef char *address;
+typedef short int shortint;
+typedef float real;
+typedef double doublereal;
+typedef struct { real r, i; } complex;
+typedef struct { doublereal r, i; } doublecomplex;
+#ifdef _MSC_VER
+static inline _Fcomplex Cf(complex *z) {_Fcomplex zz={z->r , z->i}; return zz;}
+static inline _Dcomplex Cd(doublecomplex *z) {_Dcomplex zz={z->r , z->i};return zz;}
+static inline _Fcomplex * _pCf(complex *z) {return (_Fcomplex*)z;}
+static inline _Dcomplex * _pCd(doublecomplex *z) {return (_Dcomplex*)z;}
+#else
+static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;}
+static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;}
+static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;}
+static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;}
+#endif
+#define pCf(z) (*_pCf(z))
+#define pCd(z) (*_pCd(z))
+typedef int logical;
+typedef short int shortlogical;
+typedef char logical1;
+typedef char integer1;
+
+#define TRUE_ (1)
+#define FALSE_ (0)
+
+/* Extern is for use with -E */
+#ifndef Extern
+#define Extern extern
+#endif
+
+/* I/O stuff */
+
+typedef int flag;
+typedef int ftnlen;
+typedef int ftnint;
+
+/*external read, write*/
+typedef struct
+{ flag cierr;
+ ftnint ciunit;
+ flag ciend;
+ char *cifmt;
+ ftnint cirec;
+} cilist;
+
+/*internal read, write*/
+typedef struct
+{ flag icierr;
+ char *iciunit;
+ flag iciend;
+ char *icifmt;
+ ftnint icirlen;
+ ftnint icirnum;
+} icilist;
+
+/*open*/
+typedef struct
+{ flag oerr;
+ ftnint ounit;
+ char *ofnm;
+ ftnlen ofnmlen;
+ char *osta;
+ char *oacc;
+ char *ofm;
+ ftnint orl;
+ char *oblnk;
+} olist;
+
+/*close*/
+typedef struct
+{ flag cerr;
+ ftnint cunit;
+ char *csta;
+} cllist;
+
+/*rewind, backspace, endfile*/
+typedef struct
+{ flag aerr;
+ ftnint aunit;
+} alist;
+
+/* inquire */
+typedef struct
+{ flag inerr;
+ ftnint inunit;
+ char *infile;
+ ftnlen infilen;
+ ftnint *inex; /*parameters in standard's order*/
+ ftnint *inopen;
+ ftnint *innum;
+ ftnint *innamed;
+ char *inname;
+ ftnlen innamlen;
+ char *inacc;
+ ftnlen inacclen;
+ char *inseq;
+ ftnlen inseqlen;
+ char *indir;
+ ftnlen indirlen;
+ char *infmt;
+ ftnlen infmtlen;
+ char *inform;
+ ftnint informlen;
+ char *inunf;
+ ftnlen inunflen;
+ ftnint *inrecl;
+ ftnint *innrec;
+ char *inblank;
+ ftnlen inblanklen;
+} inlist;
+
+#define VOID void
+
+union Multitype { /* for multiple entry points */
+ integer1 g;
+ shortint h;
+ integer i;
+ /* longint j; */
+ real r;
+ doublereal d;
+ complex c;
+ doublecomplex z;
+ };
+
+typedef union Multitype Multitype;
+
+struct Vardesc { /* for Namelist */
+ char *name;
+ char *addr;
+ ftnlen *dims;
+ int type;
+ };
+typedef struct Vardesc Vardesc;
+
+struct Namelist {
+ char *name;
+ Vardesc **vars;
+ int nvars;
+ };
+typedef struct Namelist Namelist;
+
+#define abs(x) ((x) >= 0 ? (x) : -(x))
+#define dabs(x) (fabs(x))
+#define f2cmin(a,b) ((a) <= (b) ? (a) : (b))
+#define f2cmax(a,b) ((a) >= (b) ? (a) : (b))
+#define dmin(a,b) (f2cmin(a,b))
+#define dmax(a,b) (f2cmax(a,b))
+#define bit_test(a,b) ((a) >> (b) & 1)
+#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b)))
+#define bit_set(a,b) ((a) | ((uinteger)1 << (b)))
+
+#define abort_() { sig_die("Fortran abort routine called", 1); }
+#define c_abs(z) (cabsf(Cf(z)))
+#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); }
+#ifdef _MSC_VER
+#define c_div(c, a, b) {Cf(c)._Val[0] = (Cf(a)._Val[0]/Cf(b)._Val[0]); Cf(c)._Val[1]=(Cf(a)._Val[1]/Cf(b)._Val[1]);}
+#define z_div(c, a, b) {Cd(c)._Val[0] = (Cd(a)._Val[0]/Cd(b)._Val[0]); Cd(c)._Val[1]=(Cd(a)._Val[1]/Cd(b)._Val[1]);}
+#else
+#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);}
+#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);}
+#endif
+#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));}
+#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));}
+#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));}
+//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));}
+#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));}
+#define d_abs(x) (fabs(*(x)))
+#define d_acos(x) (acos(*(x)))
+#define d_asin(x) (asin(*(x)))
+#define d_atan(x) (atan(*(x)))
+#define d_atn2(x, y) (atan2(*(x),*(y)))
+#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); }
+#define r_cnjg(R, Z) { pCf(R) = conjf(Cf(Z)); }
+#define d_cos(x) (cos(*(x)))
+#define d_cosh(x) (cosh(*(x)))
+#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 )
+#define d_exp(x) (exp(*(x)))
+#define d_imag(z) (cimag(Cd(z)))
+#define r_imag(z) (cimagf(Cf(z)))
+#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define d_log(x) (log(*(x)))
+#define d_mod(x, y) (fmod(*(x), *(y)))
+#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x)))
+#define d_nint(x) u_nint(*(x))
+#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a)))
+#define d_sign(a,b) u_sign(*(a),*(b))
+#define r_sign(a,b) u_sign(*(a),*(b))
+#define d_sin(x) (sin(*(x)))
+#define d_sinh(x) (sinh(*(x)))
+#define d_sqrt(x) (sqrt(*(x)))
+#define d_tan(x) (tan(*(x)))
+#define d_tanh(x) (tanh(*(x)))
+#define i_abs(x) abs(*(x))
+#define i_dnnt(x) ((integer)u_nint(*(x)))
+#define i_len(s, n) (n)
+#define i_nint(x) ((integer)u_nint(*(x)))
+#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b)))
+#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; }
+#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d))))
+#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
+#define sig_die(s, kill) { exit(1); }
+#define s_stop(s, n) {exit(0);}
+#define z_abs(z) (cabs(Cd(z)))
+#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
+#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
+
+/* procedure parameter types for -A and -C++ */
+
+#define F2C_proc_par_types 1
+#ifdef __cplusplus
+typedef logical (*L_fp)(...);
+#else
+typedef logical (*L_fp)();
+#endif
+
+
+/* Table of constant values */
+
+static real c_b4 = 1.f;
+static real c_b5 = 0.f;
+static integer c__1 = 1;
+
+/* > \brief \b SLARF1L applies an elementary reflector to a general rectangular */
+/* matrix assuming v(lastv) = 1, where lastv is the last non-zero */
+/* element */
+
+/* =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/* http://www.netlib.org/lapack/explore-html/ */
+
+/* > Download SLARF1L + dependencies */
+/* > */
+/* > [TGZ] */
+/* > */
+/* > [ZIP] */
+/* > */
+/* > [TXT] */
+
+/* Definition: */
+/* =========== */
+
+/* SUBROUTINE SLARF1L( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) */
+
+/* CHARACTER SIDE */
+/* INTEGER INCV, LDC, M, N */
+/* REAL TAU */
+/* REAL C( LDC, * ), V( * ), WORK( * ) */
+
+
+/* > \par Purpose: */
+/* ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > SLARF1L applies a real elementary reflector H to a real m by n matrix */
+/* > C, from either the left or the right. H is represented in the form */
+/* > */
+/* > H = I - tau * v * v**T */
+/* > */
+/* > where tau is a real scalar and v is a real vector assuming v(lastv) = 1, */
+/* > where lastv is the last non-zero element. */
+/* > */
+/* > If tau = 0, then H is taken to be the unit matrix. */
+/* > \endverbatim */
+
+/* Arguments: */
+/* ========== */
+
+/* > \param[in] SIDE */
+/* > \verbatim */
+/* > SIDE is CHARACTER*1 */
+/* > = 'L': form H * C */
+/* > = 'R': form C * H */
+/* > \endverbatim */
+/* > */
+/* > \param[in] M */
+/* > \verbatim */
+/* > M is INTEGER */
+/* > The number of rows of the matrix C. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] N */
+/* > \verbatim */
+/* > N is INTEGER */
+/* > The number of columns of the matrix C. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] V */
+/* > \verbatim */
+/* > V is REAL array, dimension */
+/* > (1 + (M-1)*abs(INCV)) if SIDE = 'L' */
+/* > or (1 + (N-1)*abs(INCV)) if SIDE = 'R' */
+/* > The vector v in the representation of H. V is not used if */
+/* > TAU = 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] INCV */
+/* > \verbatim */
+/* > INCV is INTEGER */
+/* > The increment between elements of v. INCV > 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] TAU */
+/* > \verbatim */
+/* > TAU is REAL */
+/* > The value tau in the representation of H. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] C */
+/* > \verbatim */
+/* > C is REAL array, dimension (LDC,N) */
+/* > On entry, the m by n matrix C. */
+/* > On exit, C is overwritten by the matrix H * C if SIDE = 'L', */
+/* > or C * H if SIDE = 'R'. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDC */
+/* > \verbatim */
+/* > LDC is INTEGER */
+/* > The leading dimension of the array C. LDC >= f2cmax(1,M). */
+/* > \endverbatim */
+/* > */
+/* > \param[out] WORK */
+/* > \verbatim */
+/* > WORK is REAL array, dimension */
+/* > (N) if SIDE = 'L' */
+/* > or (M) if SIDE = 'R' */
+/* > \endverbatim */
+
+/* Authors: */
+/* ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \ingroup larf1l */
+
+/* ===================================================================== */
+/* Subroutine */ int slarf1l_(char *side, integer *m, integer *n, real *v,
+ integer *incv, real *tau, real *c__, integer *ldc, real *work)
+{
+ /* System generated locals */
+ integer c_dim1, c_offset, i__1;
+ real r__1;
+
+ /* Local variables */
+ integer i__;
+ logical applyleft;
+ extern /* Subroutine */ int sger_(integer *, integer *, real *, real *,
+ integer *, real *, integer *, real *, integer *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+ integer lastc;
+ extern /* Subroutine */ int sgemv_(char *, integer *, integer *, real *,
+ real *, integer *, real *, integer *, real *, real *, integer *);
+ integer lastv;
+ extern /* Subroutine */ int saxpy_(integer *, real *, real *, integer *,
+ real *, integer *);
+ extern integer ilaslc_(integer *, integer *, real *, integer *), ilaslr_(
+ integer *, integer *, real *, integer *);
+ integer firstv;
+
+
+/* -- LAPACK auxiliary routine -- */
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+
+
+/* ===================================================================== */
+
+
+ /* Parameter adjustments */
+ --v;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --work;
+
+ /* Function Body */
+ applyleft = lsame_(side, "L");
+ firstv = 1;
+ lastc = 0;
+ if (*tau != 0.f) {
+/* Set up variables for scanning V. LASTV begins pointing to the end */
+/* of V up to V(1). */
+ if (applyleft) {
+ lastv = *m;
+ } else {
+ lastv = *n;
+ }
+ i__ = 1;
+/* Look for the last non-zero row in V. */
+ while(lastv > firstv && v[i__] == 0.f) {
+ ++firstv;
+ i__ += *incv;
+ }
+ if (applyleft) {
+/* Scan for the last non-zero column in C(1:lastv,:). */
+ lastc = ilaslc_(&lastv, n, &c__[c_offset], ldc);
+ } else {
+/* Scan for the last non-zero row in C(:,1:lastv). */
+ lastc = ilaslr_(m, &lastv, &c__[c_offset], ldc);
+ }
+ }
+ if (lastc == 0) {
+ return 0;
+ }
+ if (applyleft) {
+
+/* Form H * C */
+
+ if (lastv == firstv) {
+
+/* C(lastv,1:lastc) := ( 1 - tau ) * C(lastv,1:lastc) */
+
+ r__1 = 1.f - *tau;
+ sscal_(&lastc, &r__1, &c__[lastv + c_dim1], ldc);
+ } else {
+
+/* w(1:lastc,1) := C(firstv:lastv-1,1:lastc)**T * v(firstv:lastv-1,1) */
+
+ i__1 = lastv - firstv;
+ sgemv_("Transpose", &i__1, &lastc, &c_b4, &c__[firstv + c_dim1],
+ ldc, &v[i__], incv, &c_b5, &work[1], &c__1);
+
+/* w(1:lastc,1) += C(lastv,1:lastc)**T * v(lastv,1) */
+
+ saxpy_(&lastc, &c_b4, &c__[lastv + c_dim1], ldc, &work[1], &c__1);
+
+/* C(lastv,1:lastc) += - tau * v(lastv,1) * w(1:lastc,1)**T */
+
+ r__1 = -(*tau);
+ saxpy_(&lastc, &r__1, &work[1], &c__1, &c__[lastv + c_dim1], ldc);
+
+/* C(firstv:lastv-1,1:lastc) += - tau * v(firstv:lastv-1,1) * w(1:lastc,1)**T */
+
+ i__1 = lastv - firstv;
+ r__1 = -(*tau);
+ sger_(&i__1, &lastc, &r__1, &v[i__], incv, &work[1], &c__1, &c__[
+ firstv + c_dim1], ldc);
+ }
+ } else {
+
+/* Form C * H */
+
+ if (lastv == firstv) {
+
+/* C(1:lastc,lastv) := ( 1 - tau ) * C(1:lastc,lastv) */
+
+ r__1 = 1.f - *tau;
+ sscal_(&lastc, &r__1, &c__[lastv * c_dim1 + 1], &c__1);
+ } else {
+
+/* w(1:lastc,1) := C(1:lastc,firstv:lastv-1) * v(firstv:lastv-1,1) */
+
+ i__1 = lastv - firstv;
+ sgemv_("No transpose", &lastc, &i__1, &c_b4, &c__[firstv * c_dim1
+ + 1], ldc, &v[i__], incv, &c_b5, &work[1], &c__1);
+
+/* w(1:lastc,1) += C(1:lastc,lastv) * v(lastv,1) */
+
+ saxpy_(&lastc, &c_b4, &c__[lastv * c_dim1 + 1], &c__1, &work[1], &
+ c__1);
+
+/* C(1:lastc,lastv) += - tau * v(lastv,1) * w(1:lastc,1) */
+
+ r__1 = -(*tau);
+ saxpy_(&lastc, &r__1, &work[1], &c__1, &c__[lastv * c_dim1 + 1], &
+ c__1);
+
+/* C(1:lastc,firstv:lastv-1) += - tau * w(1:lastc,1) * v(firstv:lastv-1)**T */
+
+ i__1 = lastv - firstv;
+ r__1 = -(*tau);
+ sger_(&lastc, &i__1, &r__1, &work[1], &c__1, &v[i__], incv, &c__[
+ firstv * c_dim1 + 1], ldc);
+ }
+ }
+ return 0;
+
+/* End of SLARF1L */
+
+} /* slarf1l_ */
+
diff --git a/lapack-netlib/SRC/slarf1l.f b/lapack-netlib/SRC/slarf1l.f
new file mode 100644
index 0000000000..d4fbb60108
--- /dev/null
+++ b/lapack-netlib/SRC/slarf1l.f
@@ -0,0 +1,253 @@
+*> \brief \b SLARF1L applies an elementary reflector to a general rectangular
+* matrix assuming v(lastv) = 1, where lastv is the last non-zero
+* element
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> Download SLARF1L + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE SLARF1L( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )
+*
+* .. Scalar Arguments ..
+* CHARACTER SIDE
+* INTEGER INCV, LDC, M, N
+* REAL TAU
+* ..
+* .. Array Arguments ..
+* REAL C( LDC, * ), V( * ), WORK( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> SLARF1L applies a real elementary reflector H to a real m by n matrix
+*> C, from either the left or the right. H is represented in the form
+*>
+*> H = I - tau * v * v**T
+*>
+*> where tau is a real scalar and v is a real vector assuming v(lastv) = 1,
+*> where lastv is the last non-zero element.
+*>
+*> If tau = 0, then H is taken to be the unit matrix.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] SIDE
+*> \verbatim
+*> SIDE is CHARACTER*1
+*> = 'L': form H * C
+*> = 'R': form C * H
+*> \endverbatim
+*>
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows of the matrix C.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of columns of the matrix C.
+*> \endverbatim
+*>
+*> \param[in] V
+*> \verbatim
+*> V is REAL array, dimension
+*> (1 + (M-1)*abs(INCV)) if SIDE = 'L'
+*> or (1 + (N-1)*abs(INCV)) if SIDE = 'R'
+*> The vector v in the representation of H. V is not used if
+*> TAU = 0.
+*> \endverbatim
+*>
+*> \param[in] INCV
+*> \verbatim
+*> INCV is INTEGER
+*> The increment between elements of v. INCV > 0.
+*> \endverbatim
+*>
+*> \param[in] TAU
+*> \verbatim
+*> TAU is REAL
+*> The value tau in the representation of H.
+*> \endverbatim
+*>
+*> \param[in,out] C
+*> \verbatim
+*> C is REAL array, dimension (LDC,N)
+*> On entry, the m by n matrix C.
+*> On exit, C is overwritten by the matrix H * C if SIDE = 'L',
+*> or C * H if SIDE = 'R'.
+*> \endverbatim
+*>
+*> \param[in] LDC
+*> \verbatim
+*> LDC is INTEGER
+*> The leading dimension of the array C. LDC >= max(1,M).
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is REAL array, dimension
+*> (N) if SIDE = 'L'
+*> or (M) if SIDE = 'R'
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \ingroup larf1l
+*
+* =====================================================================
+ SUBROUTINE SLARF1L( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )
+ IMPLICIT NONE
+*
+* -- LAPACK auxiliary routine --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+*
+* .. Scalar Arguments ..
+ CHARACTER SIDE
+ INTEGER INCV, LDC, M, N
+ REAL TAU
+* ..
+* .. Array Arguments ..
+ REAL C( LDC, * ), V( * ), WORK( * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE, ZERO
+ PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL APPLYLEFT
+ INTEGER I, LASTV, LASTC, FIRSTV
+* ..
+* .. External Subroutines ..
+ EXTERNAL SGEMV, SGER, SAXPY, SSCAL
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILASLR, ILASLC
+ EXTERNAL LSAME, ILASLR, ILASLC
+* ..
+* .. Executable Statements ..
+*
+ APPLYLEFT = LSAME( SIDE, 'L' )
+ FIRSTV = 1
+ LASTC = 0
+ IF( TAU.NE.ZERO ) THEN
+! Set up variables for scanning V. LASTV begins pointing to the end
+! of V up to V(1).
+ IF( APPLYLEFT ) THEN
+ LASTV = M
+ ELSE
+ LASTV = N
+ END IF
+ I = 1
+! Look for the last non-zero row in V.
+ DO WHILE( LASTV.GT.FIRSTV .AND. V( I ).EQ.ZERO )
+ FIRSTV = FIRSTV + 1
+ I = I + INCV
+ END DO
+ IF( APPLYLEFT ) THEN
+! Scan for the last non-zero column in C(1:lastv,:).
+ LASTC = ILASLC(LASTV, N, C, LDC)
+ ELSE
+! Scan for the last non-zero row in C(:,1:lastv).
+ LASTC = ILASLR(M, LASTV, C, LDC)
+ END IF
+ END IF
+ IF( LASTC.EQ.0 ) THEN
+ RETURN
+ END IF
+ IF( APPLYLEFT ) THEN
+*
+* Form H * C
+*
+ IF( LASTV.EQ.FIRSTV ) THEN
+*
+* C(lastv,1:lastc) := ( 1 - tau ) * C(lastv,1:lastc)
+*
+ CALL SSCAL( LASTC, ONE - TAU, C( LASTV, 1 ), LDC )
+ ELSE
+*
+* w(1:lastc,1) := C(firstv:lastv-1,1:lastc)**T * v(firstv:lastv-1,1)
+*
+ CALL SGEMV( 'Transpose', LASTV - FIRSTV, LASTC, ONE,
+ $ C( FIRSTV, 1 ), LDC, V( I ), INCV, ZERO,
+ $ WORK, 1 )
+*
+* w(1:lastc,1) += C(lastv,1:lastc)**T * v(lastv,1)
+*
+ CALL SAXPY( LASTC, ONE, C( LASTV, 1 ), LDC, WORK, 1 )
+*
+* C(lastv,1:lastc) += - tau * v(lastv,1) * w(1:lastc,1)**T
+*
+ CALL SAXPY( LASTC, -TAU, WORK, 1, C( LASTV, 1 ), LDC )
+*
+* C(firstv:lastv-1,1:lastc) += - tau * v(firstv:lastv-1,1) * w(1:lastc,1)**T
+*
+ CALL SGER( LASTV - FIRSTV, LASTC, -TAU, V( I ), INCV,
+ $ WORK, 1, C( FIRSTV, 1 ), LDC)
+ END IF
+ ELSE
+*
+* Form C * H
+*
+ IF( LASTV.EQ.FIRSTV ) THEN
+*
+* C(1:lastc,lastv) := ( 1 - tau ) * C(1:lastc,lastv)
+*
+ CALL SSCAL( LASTC, ONE - TAU, C( 1, LASTV ), 1 )
+ ELSE
+*
+* w(1:lastc,1) := C(1:lastc,firstv:lastv-1) * v(firstv:lastv-1,1)
+*
+ CALL SGEMV( 'No transpose', LASTC, LASTV - FIRSTV, ONE,
+ $ C( 1, FIRSTV ), LDC, V( I ), INCV, ZERO,
+ $ WORK, 1 )
+*
+* w(1:lastc,1) += C(1:lastc,lastv) * v(lastv,1)
+*
+ CALL SAXPY( LASTC, ONE, C( 1, LASTV ), 1, WORK, 1 )
+*
+* C(1:lastc,lastv) += - tau * v(lastv,1) * w(1:lastc,1)
+*
+ CALL SAXPY( LASTC, -TAU, WORK, 1, C( 1, LASTV ), 1 )
+*
+* C(1:lastc,firstv:lastv-1) += - tau * w(1:lastc,1) * v(firstv:lastv-1)**T
+*
+ CALL SGER( LASTC, LASTV - FIRSTV, -TAU, WORK, 1, V( I ),
+ $ INCV, C( 1, FIRSTV ), LDC )
+ END IF
+ END IF
+ RETURN
+*
+* End of SLARF1L
+*
+ END
diff --git a/lapack-netlib/SRC/sopmtr.f b/lapack-netlib/SRC/sopmtr.f
index c1148e01f4..19e9f6af3a 100644
--- a/lapack-netlib/SRC/sopmtr.f
+++ b/lapack-netlib/SRC/sopmtr.f
@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
-*> \htmlonly
*> Download SOPMTR + dependencies
*>
*> [TGZ]
@@ -13,7 +12,6 @@
*> [ZIP]
*>
*> [TXT]
-*> \endhtmlonly
*
* Definition:
* ===========
@@ -142,11 +140,13 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \ingroup realOTHERcomputational
+*> \ingroup upmtr
*
* =====================================================================
- SUBROUTINE SOPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC, WORK,
+ SUBROUTINE SOPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC,
+ $ WORK,
$ INFO )
+ IMPLICIT NONE
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
@@ -162,21 +162,16 @@ SUBROUTINE SOPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC, WORK,
*
* =====================================================================
*
-* .. Parameters ..
- REAL ONE
- PARAMETER ( ONE = 1.0E+0 )
-* ..
* .. Local Scalars ..
LOGICAL FORWRD, LEFT, NOTRAN, UPPER
INTEGER I, I1, I2, I3, IC, II, JC, MI, NI, NQ
- REAL AII
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
- EXTERNAL SLARF, XERBLA
+ EXTERNAL SLARF1F, SLARF1L, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
@@ -260,11 +255,8 @@ SUBROUTINE SOPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC, WORK,
*
* Apply H(i)
*
- AII = AP( II )
- AP( II ) = ONE
- CALL SLARF( SIDE, MI, NI, AP( II-I+1 ), 1, TAU( I ), C, LDC,
- $ WORK )
- AP( II ) = AII
+ CALL SLARF1L( SIDE, MI, NI, AP( II-I+1 ), 1, TAU( I ), C,
+ $ LDC, WORK )
*
IF( FORWRD ) THEN
II = II + I + 2
@@ -300,8 +292,6 @@ SUBROUTINE SOPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC, WORK,
END IF
*
DO 20 I = I1, I2, I3
- AII = AP( II )
- AP( II ) = ONE
IF( LEFT ) THEN
*
* H(i) is applied to C(i+1:m,1:n)
@@ -318,9 +308,8 @@ SUBROUTINE SOPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC, WORK,
*
* Apply H(i)
*
- CALL SLARF( SIDE, MI, NI, AP( II ), 1, TAU( I ),
- $ C( IC, JC ), LDC, WORK )
- AP( II ) = AII
+ CALL SLARF1F( SIDE, MI, NI, AP( II ), 1, TAU( I ),
+ $ C( IC, JC ), LDC, WORK )
*
IF( FORWRD ) THEN
II = II + NQ - I + 1
diff --git a/lapack-netlib/SRC/sorbdb.f b/lapack-netlib/SRC/sorbdb.f
index 351172ff16..17aba5db49 100644
--- a/lapack-netlib/SRC/sorbdb.f
+++ b/lapack-netlib/SRC/sorbdb.f
@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
-*> \htmlonly
*> Download SORBDB + dependencies
*>
*> [TGZ]
@@ -13,7 +12,6 @@
*> [ZIP]
*>
*> [TXT]
-*> \endhtmlonly
*
* Definition:
* ===========
@@ -255,7 +253,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \ingroup realOTHERcomputational
+*> \ingroup unbdb
*
*> \par Further Details:
* =====================
@@ -281,9 +279,11 @@
*> Algorithms, 50(1):33-65, 2009.
*>
* =====================================================================
- SUBROUTINE SORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12,
+ SUBROUTINE SORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12,
+ $ LDX12,
$ X21, LDX21, X22, LDX22, THETA, PHI, TAUP1,
$ TAUP2, TAUQ1, TAUQ2, WORK, LWORK, INFO )
+ IMPLICIT NONE
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
@@ -306,8 +306,6 @@ SUBROUTINE SORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12,
* .. Parameters ..
REAL REALONE
PARAMETER ( REALONE = 1.0E0 )
- REAL ONE
- PARAMETER ( ONE = 1.0E0 )
* ..
* .. Local Scalars ..
LOGICAL COLMAJOR, LQUERY
@@ -315,7 +313,8 @@ SUBROUTINE SORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12,
REAL Z1, Z2, Z3, Z4
* ..
* .. External Subroutines ..
- EXTERNAL SAXPY, SLARF, SLARFGP, SSCAL, XERBLA
+ EXTERNAL SAXPY, SLARF1F, SLARFGP, SSCAL,
+ $ XERBLA
* ..
* .. External Functions ..
REAL SNRM2
@@ -374,7 +373,7 @@ SUBROUTINE SORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12,
IF( INFO .EQ. 0 ) THEN
LWORKOPT = M - Q
LWORKMIN = M - Q
- WORK(1) = LWORKOPT
+ WORK(1) = REAL( LWORKOPT )
IF( LWORK .LT. LWORKMIN .AND. .NOT. LQUERY ) THEN
INFO = -21
END IF
@@ -398,14 +397,16 @@ SUBROUTINE SORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12,
CALL SSCAL( P-I+1, Z1, X11(I,I), 1 )
ELSE
CALL SSCAL( P-I+1, Z1*COS(PHI(I-1)), X11(I,I), 1 )
- CALL SAXPY( P-I+1, -Z1*Z3*Z4*SIN(PHI(I-1)), X12(I,I-1),
+ CALL SAXPY( P-I+1, -Z1*Z3*Z4*SIN(PHI(I-1)), X12(I,
+ $ I-1),
$ 1, X11(I,I), 1 )
END IF
IF( I .EQ. 1 ) THEN
CALL SSCAL( M-P-I+1, Z2, X21(I,I), 1 )
ELSE
CALL SSCAL( M-P-I+1, Z2*COS(PHI(I-1)), X21(I,I), 1 )
- CALL SAXPY( M-P-I+1, -Z2*Z3*Z4*SIN(PHI(I-1)), X22(I,I-1),
+ CALL SAXPY( M-P-I+1, -Z2*Z3*Z4*SIN(PHI(I-1)), X22(I,
+ $ I-1),
$ 1, X21(I,I), 1 )
END IF
*
@@ -413,44 +414,47 @@ SUBROUTINE SORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12,
$ SNRM2( P-I+1, X11(I,I), 1 ) )
*
IF( P .GT. I ) THEN
- CALL SLARFGP( P-I+1, X11(I,I), X11(I+1,I), 1, TAUP1(I) )
+ CALL SLARFGP( P-I+1, X11(I,I), X11(I+1,I), 1,
+ $ TAUP1(I) )
ELSE IF( P .EQ. I ) THEN
CALL SLARFGP( P-I+1, X11(I,I), X11(I,I), 1, TAUP1(I) )
END IF
- X11(I,I) = ONE
IF ( M-P .GT. I ) THEN
CALL SLARFGP( M-P-I+1, X21(I,I), X21(I+1,I), 1,
$ TAUP2(I) )
ELSE IF ( M-P .EQ. I ) THEN
- CALL SLARFGP( M-P-I+1, X21(I,I), X21(I,I), 1, TAUP2(I) )
+ CALL SLARFGP( M-P-I+1, X21(I,I), X21(I,I), 1,
+ $ TAUP2(I) )
END IF
- X21(I,I) = ONE
*
IF ( Q .GT. I ) THEN
- CALL SLARF( 'L', P-I+1, Q-I, X11(I,I), 1, TAUP1(I),
- $ X11(I,I+1), LDX11, WORK )
+ CALL SLARF1F( 'L', P-I+1, Q-I, X11(I,I), 1, TAUP1(I),
+ $ X11(I,I+1), LDX11, WORK )
END IF
IF ( M-Q+1 .GT. I ) THEN
- CALL SLARF( 'L', P-I+1, M-Q-I+1, X11(I,I), 1, TAUP1(I),
- $ X12(I,I), LDX12, WORK )
+ CALL SLARF1F( 'L', P-I+1, M-Q-I+1, X11(I,I), 1,
+ $ TAUP1(I), X12(I,I), LDX12, WORK )
END IF
IF ( Q .GT. I ) THEN
- CALL SLARF( 'L', M-P-I+1, Q-I, X21(I,I), 1, TAUP2(I),
- $ X21(I,I+1), LDX21, WORK )
+ CALL SLARF1F( 'L', M-P-I+1, Q-I, X21(I,I), 1,
+ $ TAUP2(I), X21(I,I+1), LDX21, WORK )
END IF
IF ( M-Q+1 .GT. I ) THEN
- CALL SLARF( 'L', M-P-I+1, M-Q-I+1, X21(I,I), 1, TAUP2(I),
- $ X22(I,I), LDX22, WORK )
+ CALL SLARF1F( 'L', M-P-I+1, M-Q-I+1, X21(I,I), 1,
+ $ TAUP2(I), X22(I,I), LDX22, WORK )
END IF
*
IF( I .LT. Q ) THEN
CALL SSCAL( Q-I, -Z1*Z3*SIN(THETA(I)), X11(I,I+1),
$ LDX11 )
- CALL SAXPY( Q-I, Z2*Z3*COS(THETA(I)), X21(I,I+1), LDX21,
+ CALL SAXPY( Q-I, Z2*Z3*COS(THETA(I)), X21(I,I+1),
+ $ LDX21,
$ X11(I,I+1), LDX11 )
END IF
- CALL SSCAL( M-Q-I+1, -Z1*Z4*SIN(THETA(I)), X12(I,I), LDX12 )
- CALL SAXPY( M-Q-I+1, Z2*Z4*COS(THETA(I)), X22(I,I), LDX22,
+ CALL SSCAL( M-Q-I+1, -Z1*Z4*SIN(THETA(I)), X12(I,I),
+ $ LDX12 )
+ CALL SAXPY( M-Q-I+1, Z2*Z4*COS(THETA(I)), X22(I,I),
+ $ LDX22,
$ X12(I,I), LDX12 )
*
IF( I .LT. Q )
@@ -465,7 +469,6 @@ SUBROUTINE SORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12,
CALL SLARFGP( Q-I, X11(I,I+1), X11(I,I+2), LDX11,
$ TAUQ1(I) )
END IF
- X11(I,I+1) = ONE
END IF
IF ( Q+I-1 .LT. M ) THEN
IF ( M-Q .EQ. I ) THEN
@@ -476,21 +479,20 @@ SUBROUTINE SORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12,
$ TAUQ2(I) )
END IF
END IF
- X12(I,I) = ONE
*
IF( I .LT. Q ) THEN
- CALL SLARF( 'R', P-I, Q-I, X11(I,I+1), LDX11, TAUQ1(I),
- $ X11(I+1,I+1), LDX11, WORK )
- CALL SLARF( 'R', M-P-I, Q-I, X11(I,I+1), LDX11, TAUQ1(I),
- $ X21(I+1,I+1), LDX21, WORK )
+ CALL SLARF1F( 'R', P-I, Q-I, X11(I,I+1), LDX11,
+ $ TAUQ1(I), X11(I+1,I+1), LDX11, WORK )
+ CALL SLARF1F( 'R', M-P-I, Q-I, X11(I,I+1), LDX11,
+ $ TAUQ1(I), X21(I+1,I+1), LDX21, WORK )
END IF
IF ( P .GT. I ) THEN
- CALL SLARF( 'R', P-I, M-Q-I+1, X12(I,I), LDX12, TAUQ2(I),
- $ X12(I+1,I), LDX12, WORK )
+ CALL SLARF1F( 'R', P-I, M-Q-I+1, X12(I,I), LDX12,
+ $ TAUQ2(I), X12(I+1,I), LDX12, WORK )
END IF
IF ( M-P .GT. I ) THEN
- CALL SLARF( 'R', M-P-I, M-Q-I+1, X12(I,I), LDX12,
- $ TAUQ2(I), X22(I+1,I), LDX22, WORK )
+ CALL SLARF1F( 'R', M-P-I, M-Q-I+1, X12(I,I), LDX12,
+ $ TAUQ2(I), X22(I+1,I), LDX22, WORK )
END IF
*
END DO
@@ -507,15 +509,14 @@ SUBROUTINE SORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12,
CALL SLARFGP( M-Q-I+1, X12(I,I), X12(I,I+1), LDX12,
$ TAUQ2(I) )
END IF
- X12(I,I) = ONE
*
IF ( P .GT. I ) THEN
- CALL SLARF( 'R', P-I, M-Q-I+1, X12(I,I), LDX12, TAUQ2(I),
- $ X12(I+1,I), LDX12, WORK )
+ CALL SLARF1F( 'R', P-I, M-Q-I+1, X12(I,I), LDX12,
+ $ TAUQ2(I), X12(I+1,I), LDX12, WORK )
END IF
IF( M-P-Q .GE. 1 )
- $ CALL SLARF( 'R', M-P-Q, M-Q-I+1, X12(I,I), LDX12,
- $ TAUQ2(I), X22(Q+1,I), LDX22, WORK )
+ $ CALL SLARF1F( 'R', M-P-Q, M-Q-I+1, X12(I,I), LDX12,
+ $ TAUQ2(I), X22(Q+1,I), LDX22, WORK )
*
END DO
*
@@ -531,10 +532,10 @@ SUBROUTINE SORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12,
CALL SLARFGP( M-P-Q-I+1, X22(Q+I,P+I), X22(Q+I,P+I+1),
$ LDX22, TAUQ2(P+I) )
END IF
- X22(Q+I,P+I) = ONE
IF ( I .LT. M-P-Q ) THEN
- CALL SLARF( 'R', M-P-Q-I, M-P-Q-I+1, X22(Q+I,P+I), LDX22,
- $ TAUQ2(P+I), X22(Q+I+1,P+I), LDX22, WORK )
+ CALL SLARF1F( 'R', M-P-Q-I, M-P-Q-I+1, X22(Q+I,P+I),
+ $ LDX22, TAUQ2(P+I), X22(Q+I+1,P+I),
+ $ LDX22, WORK )
END IF
*
END DO
@@ -549,22 +550,25 @@ SUBROUTINE SORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12,
CALL SSCAL( P-I+1, Z1, X11(I,I), LDX11 )
ELSE
CALL SSCAL( P-I+1, Z1*COS(PHI(I-1)), X11(I,I), LDX11 )
- CALL SAXPY( P-I+1, -Z1*Z3*Z4*SIN(PHI(I-1)), X12(I-1,I),
+ CALL SAXPY( P-I+1, -Z1*Z3*Z4*SIN(PHI(I-1)), X12(I-1,
+ $ I),
$ LDX12, X11(I,I), LDX11 )
END IF
IF( I .EQ. 1 ) THEN
CALL SSCAL( M-P-I+1, Z2, X21(I,I), LDX21 )
ELSE
- CALL SSCAL( M-P-I+1, Z2*COS(PHI(I-1)), X21(I,I), LDX21 )
- CALL SAXPY( M-P-I+1, -Z2*Z3*Z4*SIN(PHI(I-1)), X22(I-1,I),
+ CALL SSCAL( M-P-I+1, Z2*COS(PHI(I-1)), X21(I,I),
+ $ LDX21 )
+ CALL SAXPY( M-P-I+1, -Z2*Z3*Z4*SIN(PHI(I-1)), X22(I-1,
+ $ I),
$ LDX22, X21(I,I), LDX21 )
END IF
*
THETA(I) = ATAN2( SNRM2( M-P-I+1, X21(I,I), LDX21 ),
$ SNRM2( P-I+1, X11(I,I), LDX11 ) )
*
- CALL SLARFGP( P-I+1, X11(I,I), X11(I,I+1), LDX11, TAUP1(I) )
- X11(I,I) = ONE
+ CALL SLARFGP( P-I+1, X11(I,I), X11(I,I+1), LDX11,
+ $ TAUP1(I) )
IF ( I .EQ. M-P ) THEN
CALL SLARFGP( M-P-I+1, X21(I,I), X21(I,I), LDX21,
$ TAUP2(I) )
@@ -572,23 +576,22 @@ SUBROUTINE SORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12,
CALL SLARFGP( M-P-I+1, X21(I,I), X21(I,I+1), LDX21,
$ TAUP2(I) )
END IF
- X21(I,I) = ONE
*
IF ( Q .GT. I ) THEN
- CALL SLARF( 'R', Q-I, P-I+1, X11(I,I), LDX11, TAUP1(I),
- $ X11(I+1,I), LDX11, WORK )
+ CALL SLARF1F( 'R', Q-I, P-I+1, X11(I,I), LDX11,
+ $ TAUP1(I), X11(I+1,I), LDX11, WORK )
END IF
IF ( M-Q+1 .GT. I ) THEN
- CALL SLARF( 'R', M-Q-I+1, P-I+1, X11(I,I), LDX11,
- $ TAUP1(I), X12(I,I), LDX12, WORK )
+ CALL SLARF1F( 'R', M-Q-I+1, P-I+1, X11(I,I), LDX11,
+ $ TAUP1(I), X12(I,I), LDX12, WORK )
END IF
IF ( Q .GT. I ) THEN
- CALL SLARF( 'R', Q-I, M-P-I+1, X21(I,I), LDX21, TAUP2(I),
- $ X21(I+1,I), LDX21, WORK )
+ CALL SLARF1F( 'R', Q-I, M-P-I+1, X21(I,I), LDX21,
+ $ TAUP2(I), X21(I+1,I), LDX21, WORK )
END IF
IF ( M-Q+1 .GT. I ) THEN
- CALL SLARF( 'R', M-Q-I+1, M-P-I+1, X21(I,I), LDX21,
- $ TAUP2(I), X22(I,I), LDX22, WORK )
+ CALL SLARF1F( 'R', M-Q-I+1, M-P-I+1, X21(I,I), LDX21,
+ $ TAUP2(I), X22(I,I), LDX22, WORK )
END IF
*
IF( I .LT. Q ) THEN
@@ -612,7 +615,6 @@ SUBROUTINE SORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12,
CALL SLARFGP( Q-I, X11(I+1,I), X11(I+2,I), 1,
$ TAUQ1(I) )
END IF
- X11(I+1,I) = ONE
END IF
IF ( M-Q .GT. I ) THEN
CALL SLARFGP( M-Q-I+1, X12(I,I), X12(I+1,I), 1,
@@ -621,19 +623,18 @@ SUBROUTINE SORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12,
CALL SLARFGP( M-Q-I+1, X12(I,I), X12(I,I), 1,
$ TAUQ2(I) )
END IF
- X12(I,I) = ONE
*
IF( I .LT. Q ) THEN
- CALL SLARF( 'L', Q-I, P-I, X11(I+1,I), 1, TAUQ1(I),
- $ X11(I+1,I+1), LDX11, WORK )
- CALL SLARF( 'L', Q-I, M-P-I, X11(I+1,I), 1, TAUQ1(I),
- $ X21(I+1,I+1), LDX21, WORK )
+ CALL SLARF1F( 'L', Q-I, P-I, X11(I+1,I), 1, TAUQ1(I),
+ $ X11(I+1,I+1), LDX11, WORK )
+ CALL SLARF1F( 'L', Q-I, M-P-I, X11(I+1,I), 1,
+ $ TAUQ1(I), X21(I+1,I+1), LDX21, WORK )
END IF
- CALL SLARF( 'L', M-Q-I+1, P-I, X12(I,I), 1, TAUQ2(I),
- $ X12(I,I+1), LDX12, WORK )
+ CALL SLARF1F( 'L', M-Q-I+1, P-I, X12(I,I), 1, TAUQ2(I),
+ $ X12(I,I+1), LDX12, WORK )
IF ( M-P-I .GT. 0 ) THEN
- CALL SLARF( 'L', M-Q-I+1, M-P-I, X12(I,I), 1, TAUQ2(I),
- $ X22(I,I+1), LDX22, WORK )
+ CALL SLARF1F( 'L', M-Q-I+1, M-P-I, X12(I,I), 1,
+ $ TAUQ2(I), X22(I,I+1), LDX22, WORK )
END IF
*
END DO
@@ -643,16 +644,16 @@ SUBROUTINE SORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12,
DO I = Q + 1, P
*
CALL SSCAL( M-Q-I+1, -Z1*Z4, X12(I,I), 1 )
- CALL SLARFGP( M-Q-I+1, X12(I,I), X12(I+1,I), 1, TAUQ2(I) )
- X12(I,I) = ONE
+ CALL SLARFGP( M-Q-I+1, X12(I,I), X12(I+1,I), 1,
+ $ TAUQ2(I) )
*
IF ( P .GT. I ) THEN
- CALL SLARF( 'L', M-Q-I+1, P-I, X12(I,I), 1, TAUQ2(I),
- $ X12(I,I+1), LDX12, WORK )
+ CALL SLARF1F( 'L', M-Q-I+1, P-I, X12(I,I), 1,
+ $ TAUQ2(I), X12(I,I+1), LDX12, WORK )
END IF
IF( M-P-Q .GE. 1 )
- $ CALL SLARF( 'L', M-Q-I+1, M-P-Q, X12(I,I), 1, TAUQ2(I),
- $ X22(I,Q+1), LDX22, WORK )
+ $ CALL SLARF1F( 'L', M-Q-I+1, M-P-Q, X12(I,I), 1,
+ $ TAUQ2(I), X22(I,Q+1), LDX22, WORK )
*
END DO
*
@@ -662,15 +663,16 @@ SUBROUTINE SORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12,
*
CALL SSCAL( M-P-Q-I+1, Z2*Z4, X22(P+I,Q+I), 1 )
IF ( M-P-Q .EQ. I ) THEN
- CALL SLARFGP( M-P-Q-I+1, X22(P+I,Q+I), X22(P+I,Q+I), 1,
+ CALL SLARFGP( M-P-Q-I+1, X22(P+I,Q+I), X22(P+I,Q+I),
+ $ 1,
$ TAUQ2(P+I) )
- X22(P+I,Q+I) = ONE
ELSE
- CALL SLARFGP( M-P-Q-I+1, X22(P+I,Q+I), X22(P+I+1,Q+I), 1,
+ CALL SLARFGP( M-P-Q-I+1, X22(P+I,Q+I), X22(P+I+1,Q+I),
+ $ 1,
$ TAUQ2(P+I) )
- X22(P+I,Q+I) = ONE
- CALL SLARF( 'L', M-P-Q-I+1, M-P-Q-I, X22(P+I,Q+I), 1,
- $ TAUQ2(P+I), X22(P+I,Q+I+1), LDX22, WORK )
+ CALL SLARF1F( 'L', M-P-Q-I+1, M-P-Q-I, X22(P+I,Q+I),
+ $ 1, TAUQ2(P+I), X22(P+I,Q+I+1), LDX22,
+ $ WORK )
END IF
*
*
diff --git a/lapack-netlib/SRC/sorbdb1.f b/lapack-netlib/SRC/sorbdb1.f
index 191e5742a4..52fb3c7b58 100644
--- a/lapack-netlib/SRC/sorbdb1.f
+++ b/lapack-netlib/SRC/sorbdb1.f
@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
-*> \htmlonly
*> Download SORBDB1 + dependencies
*>
*> [TGZ]
@@ -13,7 +12,6 @@
*> [ZIP]
*>
*> [TXT]
-*> \endhtmlonly
*
* Definition:
* ===========
@@ -174,7 +172,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \ingroup realOTHERcomputational
+*> \ingroup unbdb1
*
*> \par Further Details:
* =====================
@@ -198,8 +196,10 @@
*> Algorithms, 50(1):33-65, 2009.
*>
* =====================================================================
- SUBROUTINE SORBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
+ SUBROUTINE SORBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA,
+ $ PHI,
$ TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO )
+ IMPLICIT NONE
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
@@ -216,10 +216,6 @@ SUBROUTINE SORBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
*
* ====================================================================
*
-* .. Parameters ..
- REAL ONE
- PARAMETER ( ONE = 1.0E0 )
-* ..
* .. Local Scalars ..
REAL C, S
INTEGER CHILDINFO, I, ILARF, IORBDB5, LLARF, LORBDB5,
@@ -227,7 +223,8 @@ SUBROUTINE SORBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
LOGICAL LQUERY
* ..
* .. External Subroutines ..
- EXTERNAL SLARF, SLARFGP, SORBDB5, SROT, XERBLA
+ EXTERNAL SLARF1F, SLARFGP, SORBDB5, SROT,
+ $ XERBLA
* ..
* .. External Functions ..
REAL SNRM2
@@ -264,7 +261,7 @@ SUBROUTINE SORBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
LORBDB5 = Q-2
LWORKOPT = MAX( ILARF+LLARF-1, IORBDB5+LORBDB5-1 )
LWORKMIN = LWORKOPT
- WORK(1) = LWORKOPT
+ WORK(1) = REAL( LWORKOPT )
IF( LWORK .LT. LWORKMIN .AND. .NOT.LQUERY ) THEN
INFO = -14
END IF
@@ -285,22 +282,22 @@ SUBROUTINE SORBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
THETA(I) = ATAN2( X21(I,I), X11(I,I) )
C = COS( THETA(I) )
S = SIN( THETA(I) )
- X11(I,I) = ONE
- X21(I,I) = ONE
- CALL SLARF( 'L', P-I+1, Q-I, X11(I,I), 1, TAUP1(I), X11(I,I+1),
- $ LDX11, WORK(ILARF) )
- CALL SLARF( 'L', M-P-I+1, Q-I, X21(I,I), 1, TAUP2(I),
- $ X21(I,I+1), LDX21, WORK(ILARF) )
+ CALL SLARF1F( 'L', P-I+1, Q-I, X11(I,I), 1, TAUP1(I), X11(I,
+ $ I+1), LDX11, WORK(ILARF) )
+ CALL SLARF1F( 'L', M-P-I+1, Q-I, X21(I,I), 1, TAUP2(I),
+ $ X21(I,I+1), LDX21, WORK(ILARF) )
*
IF( I .LT. Q ) THEN
- CALL SROT( Q-I, X11(I,I+1), LDX11, X21(I,I+1), LDX21, C, S )
- CALL SLARFGP( Q-I, X21(I,I+1), X21(I,I+2), LDX21, TAUQ1(I) )
+ CALL SROT( Q-I, X11(I,I+1), LDX11, X21(I,I+1), LDX21, C,
+ $ S )
+ CALL SLARFGP( Q-I, X21(I,I+1), X21(I,I+2), LDX21,
+ $ TAUQ1(I) )
S = X21(I,I+1)
- X21(I,I+1) = ONE
- CALL SLARF( 'R', P-I, Q-I, X21(I,I+1), LDX21, TAUQ1(I),
- $ X11(I+1,I+1), LDX11, WORK(ILARF) )
- CALL SLARF( 'R', M-P-I, Q-I, X21(I,I+1), LDX21, TAUQ1(I),
- $ X21(I+1,I+1), LDX21, WORK(ILARF) )
+ CALL SLARF1F( 'R', P-I, Q-I, X21(I,I+1), LDX21, TAUQ1(I),
+ $ X11(I+1,I+1), LDX11, WORK(ILARF) )
+ CALL SLARF1F( 'R', M-P-I, Q-I, X21(I,I+1), LDX21,
+ $ TAUQ1(I), X21(I+1,I+1), LDX21,
+ $ WORK(ILARF) )
C = SQRT( SNRM2( P-I, X11(I+1,I+1), 1 )**2
$ + SNRM2( M-P-I, X21(I+1,I+1), 1 )**2 )
PHI(I) = ATAN2( S, C )
diff --git a/lapack-netlib/SRC/sorbdb2.f b/lapack-netlib/SRC/sorbdb2.f
index b2ff34bb1e..f4107d0d1f 100644
--- a/lapack-netlib/SRC/sorbdb2.f
+++ b/lapack-netlib/SRC/sorbdb2.f
@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
-*> \htmlonly
*> Download SORBDB2 + dependencies
*>
*> [TGZ]
@@ -13,7 +12,6 @@
*> [ZIP]
*>
*> [TXT]
-*> \endhtmlonly
*
* Definition:
* ===========
@@ -172,7 +170,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \ingroup realOTHERcomputational
+*> \ingroup unbdb2
*
*> \par Further Details:
* =====================
@@ -196,8 +194,10 @@
*> Algorithms, 50(1):33-65, 2009.
*>
* =====================================================================
- SUBROUTINE SORBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
+ SUBROUTINE SORBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA,
+ $ PHI,
$ TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO )
+ IMPLICIT NONE
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
@@ -215,8 +215,8 @@ SUBROUTINE SORBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
* ====================================================================
*
* .. Parameters ..
- REAL NEGONE, ONE
- PARAMETER ( NEGONE = -1.0E0, ONE = 1.0E0 )
+ REAL NEGONE
+ PARAMETER ( NEGONE = -1.0E0 )
* ..
* .. Local Scalars ..
REAL C, S
@@ -225,7 +225,8 @@ SUBROUTINE SORBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
LOGICAL LQUERY
* ..
* .. External Subroutines ..
- EXTERNAL SLARF, SLARFGP, SORBDB5, SROT, SSCAL, XERBLA
+ EXTERNAL SLARF1F, SLARFGP, SORBDB5, SROT, SSCAL,
+ $ XERBLA
* ..
* .. External Functions ..
REAL SNRM2
@@ -262,7 +263,7 @@ SUBROUTINE SORBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
LORBDB5 = Q-1
LWORKOPT = MAX( ILARF+LLARF-1, IORBDB5+LORBDB5-1 )
LWORKMIN = LWORKOPT
- WORK(1) = LWORKOPT
+ WORK(1) = REAL( LWORKOPT )
IF( LWORK .LT. LWORKMIN .AND. .NOT.LQUERY ) THEN
INFO = -14
END IF
@@ -279,15 +280,15 @@ SUBROUTINE SORBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
DO I = 1, P
*
IF( I .GT. 1 ) THEN
- CALL SROT( Q-I+1, X11(I,I), LDX11, X21(I-1,I), LDX21, C, S )
+ CALL SROT( Q-I+1, X11(I,I), LDX11, X21(I-1,I), LDX21, C,
+ $ S )
END IF
CALL SLARFGP( Q-I+1, X11(I,I), X11(I,I+1), LDX11, TAUQ1(I) )
C = X11(I,I)
- X11(I,I) = ONE
- CALL SLARF( 'R', P-I, Q-I+1, X11(I,I), LDX11, TAUQ1(I),
- $ X11(I+1,I), LDX11, WORK(ILARF) )
- CALL SLARF( 'R', M-P-I+1, Q-I+1, X11(I,I), LDX11, TAUQ1(I),
- $ X21(I,I), LDX21, WORK(ILARF) )
+ CALL SLARF1F( 'R', P-I, Q-I+1, X11(I,I), LDX11, TAUQ1(I),
+ $ X11(I+1,I), LDX11, WORK(ILARF) )
+ CALL SLARF1F( 'R', M-P-I+1, Q-I+1, X11(I,I), LDX11,
+ $ TAUQ1(I), X21(I,I), LDX21, WORK(ILARF) )
S = SQRT( SNRM2( P-I, X11(I+1,I), 1 )**2
$ + SNRM2( M-P-I+1, X21(I,I), 1 )**2 )
THETA(I) = ATAN2( S, C )
@@ -302,13 +303,11 @@ SUBROUTINE SORBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
PHI(I) = ATAN2( X11(I+1,I), X21(I,I) )
C = COS( PHI(I) )
S = SIN( PHI(I) )
- X11(I+1,I) = ONE
- CALL SLARF( 'L', P-I, Q-I, X11(I+1,I), 1, TAUP1(I),
- $ X11(I+1,I+1), LDX11, WORK(ILARF) )
+ CALL SLARF1F( 'L', P-I, Q-I, X11(I+1,I), 1, TAUP1(I),
+ $ X11(I+1,I+1), LDX11, WORK(ILARF) )
END IF
- X21(I,I) = ONE
- CALL SLARF( 'L', M-P-I+1, Q-I, X21(I,I), 1, TAUP2(I),
- $ X21(I,I+1), LDX21, WORK(ILARF) )
+ CALL SLARF1F( 'L', M-P-I+1, Q-I, X21(I,I), 1, TAUP2(I),
+ $ X21(I,I+1), LDX21, WORK(ILARF) )
*
END DO
*
@@ -316,9 +315,8 @@ SUBROUTINE SORBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
*
DO I = P + 1, Q
CALL SLARFGP( M-P-I+1, X21(I,I), X21(I+1,I), 1, TAUP2(I) )
- X21(I,I) = ONE
- CALL SLARF( 'L', M-P-I+1, Q-I, X21(I,I), 1, TAUP2(I),
- $ X21(I,I+1), LDX21, WORK(ILARF) )
+ CALL SLARF1F( 'L', M-P-I+1, Q-I, X21(I,I), 1, TAUP2(I),
+ $ X21(I,I+1), LDX21, WORK(ILARF) )
END DO
*
RETURN
diff --git a/lapack-netlib/SRC/sorbdb3.f b/lapack-netlib/SRC/sorbdb3.f
index 99478c5d0d..3cf8f97355 100644
--- a/lapack-netlib/SRC/sorbdb3.f
+++ b/lapack-netlib/SRC/sorbdb3.f
@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
-*> \htmlonly
*> Download SORBDB3 + dependencies
*>
*> [TGZ]
@@ -13,7 +12,6 @@
*> [ZIP]
*>
*> [TXT]
-*> \endhtmlonly
*
* Definition:
* ===========
@@ -173,7 +171,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \ingroup realOTHERcomputational
+*> \ingroup unbdb3
*
*> \par Further Details:
* =====================
@@ -197,8 +195,10 @@
*> Algorithms, 50(1):33-65, 2009.
*>
* =====================================================================
- SUBROUTINE SORBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
+ SUBROUTINE SORBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA,
+ $ PHI,
$ TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO )
+ IMPLICIT NONE
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
@@ -215,10 +215,6 @@ SUBROUTINE SORBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
*
* ====================================================================
*
-* .. Parameters ..
- REAL ONE
- PARAMETER ( ONE = 1.0E0 )
-* ..
* .. Local Scalars ..
REAL C, S
INTEGER CHILDINFO, I, ILARF, IORBDB5, LLARF, LORBDB5,
@@ -226,7 +222,8 @@ SUBROUTINE SORBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
LOGICAL LQUERY
* ..
* .. External Subroutines ..
- EXTERNAL SLARF, SLARFGP, SORBDB5, SROT, XERBLA
+ EXTERNAL SLARF1F, SLARFGP, SORBDB5, SROT,
+ $ XERBLA
* ..
* .. External Functions ..
REAL SNRM2
@@ -263,7 +260,7 @@ SUBROUTINE SORBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
LORBDB5 = Q-1
LWORKOPT = MAX( ILARF+LLARF-1, IORBDB5+LORBDB5-1 )
LWORKMIN = LWORKOPT
- WORK(1) = LWORKOPT
+ WORK(1) = REAL( LWORKOPT )
IF( LWORK .LT. LWORKMIN .AND. .NOT.LQUERY ) THEN
INFO = -14
END IF
@@ -280,16 +277,16 @@ SUBROUTINE SORBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
DO I = 1, M-P
*
IF( I .GT. 1 ) THEN
- CALL SROT( Q-I+1, X11(I-1,I), LDX11, X21(I,I), LDX11, C, S )
+ CALL SROT( Q-I+1, X11(I-1,I), LDX11, X21(I,I), LDX11, C,
+ $ S )
END IF
*
CALL SLARFGP( Q-I+1, X21(I,I), X21(I,I+1), LDX21, TAUQ1(I) )
S = X21(I,I)
- X21(I,I) = ONE
- CALL SLARF( 'R', P-I+1, Q-I+1, X21(I,I), LDX21, TAUQ1(I),
- $ X11(I,I), LDX11, WORK(ILARF) )
- CALL SLARF( 'R', M-P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I),
- $ X21(I+1,I), LDX21, WORK(ILARF) )
+ CALL SLARF1F( 'R', P-I+1, Q-I+1, X21(I,I), LDX21, TAUQ1(I),
+ $ X11(I,I), LDX11, WORK(ILARF) )
+ CALL SLARF1F( 'R', M-P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I),
+ $ X21(I+1,I), LDX21, WORK(ILARF) )
C = SQRT( SNRM2( P-I+1, X11(I,I), 1 )**2
$ + SNRM2( M-P-I, X21(I+1,I), 1 )**2 )
THETA(I) = ATAN2( S, C )
@@ -299,17 +296,16 @@ SUBROUTINE SORBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
$ WORK(IORBDB5), LORBDB5, CHILDINFO )
CALL SLARFGP( P-I+1, X11(I,I), X11(I+1,I), 1, TAUP1(I) )
IF( I .LT. M-P ) THEN
- CALL SLARFGP( M-P-I, X21(I+1,I), X21(I+2,I), 1, TAUP2(I) )
+ CALL SLARFGP( M-P-I, X21(I+1,I), X21(I+2,I), 1,
+ $ TAUP2(I) )
PHI(I) = ATAN2( X21(I+1,I), X11(I,I) )
C = COS( PHI(I) )
S = SIN( PHI(I) )
- X21(I+1,I) = ONE
- CALL SLARF( 'L', M-P-I, Q-I, X21(I+1,I), 1, TAUP2(I),
- $ X21(I+1,I+1), LDX21, WORK(ILARF) )
+ CALL SLARF1F( 'L', M-P-I, Q-I, X21(I+1,I), 1, TAUP2(I),
+ $ X21(I+1,I+1), LDX21, WORK(ILARF) )
END IF
- X11(I,I) = ONE
- CALL SLARF( 'L', P-I+1, Q-I, X11(I,I), 1, TAUP1(I), X11(I,I+1),
- $ LDX11, WORK(ILARF) )
+ CALL SLARF1F( 'L', P-I+1, Q-I, X11(I,I), 1, TAUP1(I), X11(I,
+ $ I+1), LDX11, WORK(ILARF) )
*
END DO
*
@@ -317,9 +313,8 @@ SUBROUTINE SORBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
*
DO I = M-P + 1, Q
CALL SLARFGP( P-I+1, X11(I,I), X11(I+1,I), 1, TAUP1(I) )
- X11(I,I) = ONE
- CALL SLARF( 'L', P-I+1, Q-I, X11(I,I), 1, TAUP1(I), X11(I,I+1),
- $ LDX11, WORK(ILARF) )
+ CALL SLARF1F( 'L', P-I+1, Q-I, X11(I,I), 1, TAUP1(I), X11(I,
+ $ I+1), LDX11, WORK(ILARF) )
END DO
*
RETURN
diff --git a/lapack-netlib/SRC/sorbdb4.f b/lapack-netlib/SRC/sorbdb4.f
index 0fef5b759b..4bd1affa45 100644
--- a/lapack-netlib/SRC/sorbdb4.f
+++ b/lapack-netlib/SRC/sorbdb4.f
@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
-*> \htmlonly
*> Download SORBDB4 + dependencies
*>
*> [TGZ]
@@ -13,7 +12,6 @@
*> [ZIP]
*>
*> [TXT]
-*> \endhtmlonly
*
* Definition:
* ===========
@@ -184,7 +182,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \ingroup realOTHERcomputational
+*> \ingroup unbdb4
*
*> \par Further Details:
* =====================
@@ -208,9 +206,11 @@
*> Algorithms, 50(1):33-65, 2009.
*>
* =====================================================================
- SUBROUTINE SORBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
+ SUBROUTINE SORBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA,
+ $ PHI,
$ TAUP1, TAUP2, TAUQ1, PHANTOM, WORK, LWORK,
$ INFO )
+ IMPLICIT NONE
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
@@ -228,8 +228,8 @@ SUBROUTINE SORBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
* ====================================================================
*
* .. Parameters ..
- REAL NEGONE, ONE, ZERO
- PARAMETER ( NEGONE = -1.0E0, ONE = 1.0E0, ZERO = 0.0E0 )
+ REAL NEGONE, ZERO
+ PARAMETER ( NEGONE = -1.0E0, ZERO = 0.0E0 )
* ..
* .. Local Scalars ..
REAL C, S
@@ -238,7 +238,8 @@ SUBROUTINE SORBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
LOGICAL LQUERY
* ..
* .. External Subroutines ..
- EXTERNAL SLARF, SLARFGP, SORBDB5, SROT, SSCAL, XERBLA
+ EXTERNAL SLARF1F, SLARFGP, SORBDB5, SROT, SSCAL,
+ $ XERBLA
* ..
* .. External Functions ..
REAL SNRM2
@@ -276,7 +277,7 @@ SUBROUTINE SORBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
LWORKOPT = ILARF + LLARF - 1
LWORKOPT = MAX( LWORKOPT, IORBDB5 + LORBDB5 - 1 )
LWORKMIN = LWORKOPT
- WORK(1) = LWORKOPT
+ WORK(1) = REAL( LWORKOPT )
IF( LWORK .LT. LWORKMIN .AND. .NOT.LQUERY ) THEN
INFO = -14
END IF
@@ -301,43 +302,40 @@ SUBROUTINE SORBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
$ LORBDB5, CHILDINFO )
CALL SSCAL( P, NEGONE, PHANTOM(1), 1 )
CALL SLARFGP( P, PHANTOM(1), PHANTOM(2), 1, TAUP1(1) )
- CALL SLARFGP( M-P, PHANTOM(P+1), PHANTOM(P+2), 1, TAUP2(1) )
+ CALL SLARFGP( M-P, PHANTOM(P+1), PHANTOM(P+2), 1,
+ $ TAUP2(1) )
THETA(I) = ATAN2( PHANTOM(1), PHANTOM(P+1) )
C = COS( THETA(I) )
S = SIN( THETA(I) )
- PHANTOM(1) = ONE
- PHANTOM(P+1) = ONE
- CALL SLARF( 'L', P, Q, PHANTOM(1), 1, TAUP1(1), X11, LDX11,
- $ WORK(ILARF) )
- CALL SLARF( 'L', M-P, Q, PHANTOM(P+1), 1, TAUP2(1), X21,
- $ LDX21, WORK(ILARF) )
+ CALL SLARF1F( 'L', P, Q, PHANTOM(1), 1, TAUP1(1), X11,
+ $ LDX11, WORK(ILARF) )
+ CALL SLARF1F( 'L', M-P, Q, PHANTOM(P+1), 1, TAUP2(1),
+ $ X21, LDX21, WORK(ILARF) )
ELSE
CALL SORBDB5( P-I+1, M-P-I+1, Q-I+1, X11(I,I-1), 1,
$ X21(I,I-1), 1, X11(I,I), LDX11, X21(I,I),
$ LDX21, WORK(IORBDB5), LORBDB5, CHILDINFO )
CALL SSCAL( P-I+1, NEGONE, X11(I,I-1), 1 )
- CALL SLARFGP( P-I+1, X11(I,I-1), X11(I+1,I-1), 1, TAUP1(I) )
+ CALL SLARFGP( P-I+1, X11(I,I-1), X11(I+1,I-1), 1,
+ $ TAUP1(I) )
CALL SLARFGP( M-P-I+1, X21(I,I-1), X21(I+1,I-1), 1,
$ TAUP2(I) )
THETA(I) = ATAN2( X11(I,I-1), X21(I,I-1) )
C = COS( THETA(I) )
S = SIN( THETA(I) )
- X11(I,I-1) = ONE
- X21(I,I-1) = ONE
- CALL SLARF( 'L', P-I+1, Q-I+1, X11(I,I-1), 1, TAUP1(I),
- $ X11(I,I), LDX11, WORK(ILARF) )
- CALL SLARF( 'L', M-P-I+1, Q-I+1, X21(I,I-1), 1, TAUP2(I),
- $ X21(I,I), LDX21, WORK(ILARF) )
+ CALL SLARF1F( 'L', P-I+1, Q-I+1, X11(I,I-1), 1, TAUP1(I),
+ $ X11(I,I), LDX11, WORK(ILARF) )
+ CALL SLARF1F( 'L', M-P-I+1, Q-I+1, X21(I,I-1), 1,
+ $ TAUP2(I), X21(I,I), LDX21, WORK(ILARF) )
END IF
*
CALL SROT( Q-I+1, X11(I,I), LDX11, X21(I,I), LDX21, S, -C )
CALL SLARFGP( Q-I+1, X21(I,I), X21(I,I+1), LDX21, TAUQ1(I) )
C = X21(I,I)
- X21(I,I) = ONE
- CALL SLARF( 'R', P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I),
- $ X11(I+1,I), LDX11, WORK(ILARF) )
- CALL SLARF( 'R', M-P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I),
- $ X21(I+1,I), LDX21, WORK(ILARF) )
+ CALL SLARF1F( 'R', P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I),
+ $ X11(I+1,I), LDX11, WORK(ILARF) )
+ CALL SLARF1F( 'R', M-P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I),
+ $ X21(I+1,I), LDX21, WORK(ILARF) )
IF( I .LT. M-Q ) THEN
S = SQRT( SNRM2( P-I, X11(I+1,I), 1 )**2
$ + SNRM2( M-P-I, X21(I+1,I), 1 )**2 )
@@ -350,21 +348,21 @@ SUBROUTINE SORBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
*
DO I = M - Q + 1, P
CALL SLARFGP( Q-I+1, X11(I,I), X11(I,I+1), LDX11, TAUQ1(I) )
- X11(I,I) = ONE
- CALL SLARF( 'R', P-I, Q-I+1, X11(I,I), LDX11, TAUQ1(I),
- $ X11(I+1,I), LDX11, WORK(ILARF) )
- CALL SLARF( 'R', Q-P, Q-I+1, X11(I,I), LDX11, TAUQ1(I),
- $ X21(M-Q+1,I), LDX21, WORK(ILARF) )
+ CALL SLARF1F( 'R', P-I, Q-I+1, X11(I,I), LDX11, TAUQ1(I),
+ $ X11(I+1,I), LDX11, WORK(ILARF) )
+ CALL SLARF1F( 'R', Q-P, Q-I+1, X11(I,I), LDX11, TAUQ1(I),
+ $ X21(M-Q+1,I), LDX21, WORK(ILARF) )
END DO
*
* Reduce the bottom-right portion of X21 to [ 0 I ]
*
DO I = P + 1, Q
- CALL SLARFGP( Q-I+1, X21(M-Q+I-P,I), X21(M-Q+I-P,I+1), LDX21,
+ CALL SLARFGP( Q-I+1, X21(M-Q+I-P,I), X21(M-Q+I-P,I+1),
+ $ LDX21,
$ TAUQ1(I) )
- X21(M-Q+I-P,I) = ONE
- CALL SLARF( 'R', Q-I, Q-I+1, X21(M-Q+I-P,I), LDX21, TAUQ1(I),
- $ X21(M-Q+I-P+1,I), LDX21, WORK(ILARF) )
+ CALL SLARF1F( 'R', Q-I, Q-I+1, X21(M-Q+I-P,I), LDX21,
+ $ TAUQ1(I), X21(M-Q+I-P+1,I), LDX21,
+ $ WORK(ILARF) )
END DO
*
RETURN
diff --git a/lapack-netlib/SRC/sorg2l.f b/lapack-netlib/SRC/sorg2l.f
index aa0dd0a08e..bf5c9b0ec7 100644
--- a/lapack-netlib/SRC/sorg2l.f
+++ b/lapack-netlib/SRC/sorg2l.f
@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
-*> \htmlonly
*> Download SORG2L + dependencies
*>
*> [TGZ]
@@ -13,7 +12,6 @@
*> [ZIP]
*>
*> [TXT]
-*> \endhtmlonly
*
* Definition:
* ===========
@@ -107,10 +105,11 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \ingroup realOTHERcomputational
+*> \ingroup ung2l
*
* =====================================================================
SUBROUTINE SORG2L( M, N, K, A, LDA, TAU, WORK, INFO )
+ IMPLICIT NONE
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
@@ -133,7 +132,7 @@ SUBROUTINE SORG2L( M, N, K, A, LDA, TAU, WORK, INFO )
INTEGER I, II, J, L
* ..
* .. External Subroutines ..
- EXTERNAL SLARF, SSCAL, XERBLA
+ EXTERNAL SLARF1L, SSCAL, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
@@ -177,8 +176,8 @@ SUBROUTINE SORG2L( M, N, K, A, LDA, TAU, WORK, INFO )
* Apply H(i) to A(1:m-k+i,1:n-k+i) from the left
*
A( M-N+II, II ) = ONE
- CALL SLARF( 'Left', M-N+II, II-1, A( 1, II ), 1, TAU( I ), A,
- $ LDA, WORK )
+ CALL SLARF1L( 'Left', M-N+II, II-1, A( 1, II ), 1, TAU( I ),
+ $ A, LDA, WORK )
CALL SSCAL( M-N+II-1, -TAU( I ), A( 1, II ), 1 )
A( M-N+II, II ) = ONE - TAU( I )
*
diff --git a/lapack-netlib/SRC/sorg2r.f b/lapack-netlib/SRC/sorg2r.f
index 3a8aa33a02..c6bbe7506a 100644
--- a/lapack-netlib/SRC/sorg2r.f
+++ b/lapack-netlib/SRC/sorg2r.f
@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
-*> \htmlonly
*> Download SORG2R + dependencies
*>
*> [TGZ]
@@ -13,7 +12,6 @@
*> [ZIP]
*>
*> [TXT]
-*> \endhtmlonly
*
* Definition:
* ===========
@@ -107,10 +105,11 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \ingroup realOTHERcomputational
+*> \ingroup ung2r
*
* =====================================================================
SUBROUTINE SORG2R( M, N, K, A, LDA, TAU, WORK, INFO )
+ IMPLICIT NONE
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
@@ -133,7 +132,7 @@ SUBROUTINE SORG2R( M, N, K, A, LDA, TAU, WORK, INFO )
INTEGER I, J, L
* ..
* .. External Subroutines ..
- EXTERNAL SLARF, SSCAL, XERBLA
+ EXTERNAL SLARF1F, SSCAL, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
@@ -176,9 +175,8 @@ SUBROUTINE SORG2R( M, N, K, A, LDA, TAU, WORK, INFO )
* Apply H(i) to A(i:m,i:n) from the left
*
IF( I.LT.N ) THEN
- A( I, I ) = ONE
- CALL SLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ),
- $ A( I, I+1 ), LDA, WORK )
+ CALL SLARF1F( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ),
+ $ A( I, I+1 ), LDA, WORK )
END IF
IF( I.LT.M )
$ CALL SSCAL( M-I, -TAU( I ), A( I+1, I ), 1 )
diff --git a/lapack-netlib/SRC/sorgl2.f b/lapack-netlib/SRC/sorgl2.f
index d85c388749..2bea2836f9 100644
--- a/lapack-netlib/SRC/sorgl2.f
+++ b/lapack-netlib/SRC/sorgl2.f
@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
-*> \htmlonly
*> Download SORGL2 + dependencies
*>
*> [TGZ]
@@ -13,7 +12,6 @@
*> [ZIP]
*>
*> [TXT]
-*> \endhtmlonly
*
* Definition:
* ===========
@@ -106,10 +104,11 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \ingroup realOTHERcomputational
+*> \ingroup ungl2
*
* =====================================================================
SUBROUTINE SORGL2( M, N, K, A, LDA, TAU, WORK, INFO )
+ IMPLICIT NONE
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
@@ -132,7 +131,7 @@ SUBROUTINE SORGL2( M, N, K, A, LDA, TAU, WORK, INFO )
INTEGER I, J, L
* ..
* .. External Subroutines ..
- EXTERNAL SLARF, SSCAL, XERBLA
+ EXTERNAL SLARF1F, SSCAL, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
@@ -180,9 +179,8 @@ SUBROUTINE SORGL2( M, N, K, A, LDA, TAU, WORK, INFO )
*
IF( I.LT.N ) THEN
IF( I.LT.M ) THEN
- A( I, I ) = ONE
- CALL SLARF( 'Right', M-I, N-I+1, A( I, I ), LDA,
- $ TAU( I ), A( I+1, I ), LDA, WORK )
+ CALL SLARF1F( 'Right', M-I, N-I+1, A( I, I ), LDA,
+ $ TAU( I ), A( I+1, I ), LDA, WORK )
END IF
CALL SSCAL( N-I, -TAU( I ), A( I, I+1 ), LDA )
END IF
diff --git a/lapack-netlib/SRC/sorgr2.f b/lapack-netlib/SRC/sorgr2.f
index 12bb90c782..aca697e0cd 100644
--- a/lapack-netlib/SRC/sorgr2.f
+++ b/lapack-netlib/SRC/sorgr2.f
@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
-*> \htmlonly
*> Download SORGR2 + dependencies
*>
*> [TGZ]
@@ -13,7 +12,6 @@
*> [ZIP]
*>
*> [TXT]
-*> \endhtmlonly
*
* Definition:
* ===========
@@ -107,10 +105,11 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \ingroup realOTHERcomputational
+*> \ingroup ungr2
*
* =====================================================================
SUBROUTINE SORGR2( M, N, K, A, LDA, TAU, WORK, INFO )
+ IMPLICIT NONE
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
@@ -133,7 +132,7 @@ SUBROUTINE SORGR2( M, N, K, A, LDA, TAU, WORK, INFO )
INTEGER I, II, J, L
* ..
* .. External Subroutines ..
- EXTERNAL SLARF, SSCAL, XERBLA
+ EXTERNAL SLARF1L, SSCAL, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
@@ -181,8 +180,8 @@ SUBROUTINE SORGR2( M, N, K, A, LDA, TAU, WORK, INFO )
* Apply H(i) to A(1:m-k+i,1:n-k+i) from the right
*
A( II, N-M+II ) = ONE
- CALL SLARF( 'Right', II-1, N-M+II, A( II, 1 ), LDA, TAU( I ),
- $ A, LDA, WORK )
+ CALL SLARF1L( 'Right', II-1, N-M+II, A( II, 1 ), LDA,
+ $ TAU( I ), A, LDA, WORK )
CALL SSCAL( N-M+II-1, -TAU( I ), A( II, 1 ), LDA )
A( II, N-M+II ) = ONE - TAU( I )
*
diff --git a/lapack-netlib/SRC/sorm2l.f b/lapack-netlib/SRC/sorm2l.f
index 2f6e3abbc3..6de9c5d8e2 100644
--- a/lapack-netlib/SRC/sorm2l.f
+++ b/lapack-netlib/SRC/sorm2l.f
@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
-*> \htmlonly
*> Download SORM2L + dependencies
*>
*> [TGZ]
@@ -13,7 +12,6 @@
*> [ZIP]
*>
*> [TXT]
-*> \endhtmlonly
*
* Definition:
* ===========
@@ -151,11 +149,12 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \ingroup realOTHERcomputational
+*> \ingroup unm2l
*
* =====================================================================
SUBROUTINE SORM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
$ WORK, INFO )
+ IMPLICIT NONE
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
@@ -171,21 +170,16 @@ SUBROUTINE SORM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
*
* =====================================================================
*
-* .. Parameters ..
- REAL ONE
- PARAMETER ( ONE = 1.0E+0 )
-* ..
* .. Local Scalars ..
LOGICAL LEFT, NOTRAN
INTEGER I, I1, I2, I3, MI, NI, NQ
- REAL AII
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
- EXTERNAL SLARF, XERBLA
+ EXTERNAL SLARF1L, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
@@ -262,11 +256,8 @@ SUBROUTINE SORM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
*
* Apply H(i)
*
- AII = A( NQ-K+I, I )
- A( NQ-K+I, I ) = ONE
- CALL SLARF( SIDE, MI, NI, A( 1, I ), 1, TAU( I ), C, LDC,
+ CALL SLARF1L( SIDE, MI, NI, A( 1, I ), 1, TAU( I ), C, LDC,
$ WORK )
- A( NQ-K+I, I ) = AII
10 CONTINUE
RETURN
*
diff --git a/lapack-netlib/SRC/sorm2r.f b/lapack-netlib/SRC/sorm2r.f
index 0e0747a005..b1fd6263f6 100644
--- a/lapack-netlib/SRC/sorm2r.f
+++ b/lapack-netlib/SRC/sorm2r.f
@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
-*> \htmlonly
*> Download SORM2R + dependencies
*>
*> [TGZ]
@@ -13,7 +12,6 @@
*> [ZIP]
*>
*> [TXT]
-*> \endhtmlonly
*
* Definition:
* ===========
@@ -151,11 +149,12 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \ingroup realOTHERcomputational
+*> \ingroup unm2r
*
* =====================================================================
SUBROUTINE SORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
$ WORK, INFO )
+ IMPLICIT NONE
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
@@ -171,21 +170,16 @@ SUBROUTINE SORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
*
* =====================================================================
*
-* .. Parameters ..
- REAL ONE
- PARAMETER ( ONE = 1.0E+0 )
-* ..
* .. Local Scalars ..
LOGICAL LEFT, NOTRAN
INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ
- REAL AII
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
- EXTERNAL SLARF, XERBLA
+ EXTERNAL SLARF1F, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
@@ -266,11 +260,8 @@ SUBROUTINE SORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
*
* Apply H(i)
*
- AII = A( I, I )
- A( I, I ) = ONE
- CALL SLARF( SIDE, MI, NI, A( I, I ), 1, TAU( I ), C( IC, JC ),
- $ LDC, WORK )
- A( I, I ) = AII
+ CALL SLARF1F( SIDE, MI, NI, A( I, I ), 1, TAU( I ), C( IC,
+ $ JC ), LDC, WORK )
10 CONTINUE
RETURN
*
diff --git a/lapack-netlib/SRC/sorml2.f b/lapack-netlib/SRC/sorml2.f
index c5705c799e..0f79de7df1 100644
--- a/lapack-netlib/SRC/sorml2.f
+++ b/lapack-netlib/SRC/sorml2.f
@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
-*> \htmlonly
*> Download SORML2 + dependencies
*>
*> [TGZ]
@@ -13,7 +12,6 @@
*> [ZIP]
*>
*> [TXT]
-*> \endhtmlonly
*
* Definition:
* ===========
@@ -151,11 +149,12 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \ingroup realOTHERcomputational
+*> \ingroup unml2
*
* =====================================================================
SUBROUTINE SORML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
$ WORK, INFO )
+ IMPLICIT NONE
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
@@ -171,21 +170,16 @@ SUBROUTINE SORML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
*
* =====================================================================
*
-* .. Parameters ..
- REAL ONE
- PARAMETER ( ONE = 1.0E+0 )
-* ..
* .. Local Scalars ..
LOGICAL LEFT, NOTRAN
INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ
- REAL AII
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
- EXTERNAL SLARF, XERBLA
+ EXTERNAL SLARF1F, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
@@ -266,11 +260,8 @@ SUBROUTINE SORML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
*
* Apply H(i)
*
- AII = A( I, I )
- A( I, I ) = ONE
- CALL SLARF( SIDE, MI, NI, A( I, I ), LDA, TAU( I ),
- $ C( IC, JC ), LDC, WORK )
- A( I, I ) = AII
+ CALL SLARF1F( SIDE, MI, NI, A( I, I ), LDA, TAU( I ),
+ $ C( IC, JC ), LDC, WORK )
10 CONTINUE
RETURN
*
diff --git a/lapack-netlib/SRC/sormr2.f b/lapack-netlib/SRC/sormr2.f
index cefe1d3092..c170f63c77 100644
--- a/lapack-netlib/SRC/sormr2.f
+++ b/lapack-netlib/SRC/sormr2.f
@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
-*> \htmlonly
*> Download SORMR2 + dependencies
*>
*> [TGZ]
@@ -13,7 +12,6 @@
*> [ZIP]
*>
*> [TXT]
-*> \endhtmlonly
*
* Definition:
* ===========
@@ -151,11 +149,12 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \ingroup realOTHERcomputational
+*> \ingroup unmr2
*
* =====================================================================
SUBROUTINE SORMR2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
$ WORK, INFO )
+ IMPLICIT NONE
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
@@ -171,21 +170,16 @@ SUBROUTINE SORMR2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
*
* =====================================================================
*
-* .. Parameters ..
- REAL ONE
- PARAMETER ( ONE = 1.0E+0 )
-* ..
* .. Local Scalars ..
LOGICAL LEFT, NOTRAN
INTEGER I, I1, I2, I3, MI, NI, NQ
- REAL AII
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
- EXTERNAL SLARF, XERBLA
+ EXTERNAL SLARF1L, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
@@ -262,11 +256,8 @@ SUBROUTINE SORMR2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
*
* Apply H(i)
*
- AII = A( I, NQ-K+I )
- A( I, NQ-K+I ) = ONE
- CALL SLARF( SIDE, MI, NI, A( I, 1 ), LDA, TAU( I ), C, LDC,
- $ WORK )
- A( I, NQ-K+I ) = AII
+ CALL SLARF1L( SIDE, MI, NI, A( I, 1 ), LDA, TAU( I ), C,
+ $ LDC, WORK )
10 CONTINUE
RETURN
*
diff --git a/lapack-netlib/SRC/zgebd2.f b/lapack-netlib/SRC/zgebd2.f
index 9a403e4008..465409943a 100644
--- a/lapack-netlib/SRC/zgebd2.f
+++ b/lapack-netlib/SRC/zgebd2.f
@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
-*> \htmlonly
*> Download ZGEBD2 + dependencies
*>
*> [TGZ]
@@ -13,7 +12,6 @@
*> [ZIP]
*>
*> [TXT]
-*> \endhtmlonly
*
* Definition:
* ===========
@@ -132,7 +130,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \ingroup complex16GEcomputational
+*> \ingroup gebd2
*
*> \par Further Details:
* =====================
@@ -186,6 +184,7 @@
*>
* =====================================================================
SUBROUTINE ZGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO )
+ IMPLICIT NONE
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
@@ -202,16 +201,14 @@ SUBROUTINE ZGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO )
* =====================================================================
*
* .. Parameters ..
- COMPLEX*16 ZERO, ONE
- PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ),
- $ ONE = ( 1.0D+0, 0.0D+0 ) )
-* ..
+ COMPLEX*16 ZERO
+ PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) )
* .. Local Scalars ..
INTEGER I
COMPLEX*16 ALPHA
* ..
* .. External Subroutines ..
- EXTERNAL XERBLA, ZLACGV, ZLARF, ZLARFG
+ EXTERNAL XERBLA, ZLACGV, ZLARF1F, ZLARFG
* ..
* .. Intrinsic Functions ..
INTRINSIC DCONJG, MAX, MIN
@@ -245,12 +242,11 @@ SUBROUTINE ZGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO )
CALL ZLARFG( M-I+1, ALPHA, A( MIN( I+1, M ), I ), 1,
$ TAUQ( I ) )
D( I ) = DBLE( ALPHA )
- A( I, I ) = ONE
*
* Apply H(i)**H to A(i:m,i+1:n) from the left
*
IF( I.LT.N )
- $ CALL ZLARF( 'Left', M-I+1, N-I, A( I, I ), 1,
+ $ CALL ZLARF1F( 'Left', M-I+1, N-I, A( I, I ), 1,
$ DCONJG( TAUQ( I ) ), A( I, I+1 ), LDA, WORK )
A( I, I ) = D( I )
*
@@ -264,11 +260,10 @@ SUBROUTINE ZGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO )
CALL ZLARFG( N-I, ALPHA, A( I, MIN( I+2, N ) ), LDA,
$ TAUP( I ) )
E( I ) = DBLE( ALPHA )
- A( I, I+1 ) = ONE
*
* Apply G(i) to A(i+1:m,i+1:n) from the right
*
- CALL ZLARF( 'Right', M-I, N-I, A( I, I+1 ), LDA,
+ CALL ZLARF1F( 'Right', M-I, N-I, A( I, I+1 ), LDA,
$ TAUP( I ), A( I+1, I+1 ), LDA, WORK )
CALL ZLACGV( N-I, A( I, I+1 ), LDA )
A( I, I+1 ) = E( I )
@@ -289,12 +284,11 @@ SUBROUTINE ZGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO )
CALL ZLARFG( N-I+1, ALPHA, A( I, MIN( I+1, N ) ), LDA,
$ TAUP( I ) )
D( I ) = DBLE( ALPHA )
- A( I, I ) = ONE
*
* Apply G(i) to A(i+1:m,i:n) from the right
*
IF( I.LT.M )
- $ CALL ZLARF( 'Right', M-I, N-I+1, A( I, I ), LDA,
+ $ CALL ZLARF1F( 'Right', M-I, N-I+1, A( I, I ), LDA,
$ TAUP( I ), A( I+1, I ), LDA, WORK )
CALL ZLACGV( N-I+1, A( I, I ), LDA )
A( I, I ) = D( I )
@@ -308,11 +302,10 @@ SUBROUTINE ZGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO )
CALL ZLARFG( M-I, ALPHA, A( MIN( I+2, M ), I ), 1,
$ TAUQ( I ) )
E( I ) = DBLE( ALPHA )
- A( I+1, I ) = ONE
*
* Apply H(i)**H to A(i+1:m,i+1:n) from the left
*
- CALL ZLARF( 'Left', M-I, N-I, A( I+1, I ), 1,
+ CALL ZLARF1F( 'Left', M-I, N-I, A( I+1, I ), 1,
$ DCONJG( TAUQ( I ) ), A( I+1, I+1 ), LDA,
$ WORK )
A( I+1, I ) = E( I )
diff --git a/lapack-netlib/SRC/zgehd2.f b/lapack-netlib/SRC/zgehd2.f
index e4d79f1b83..4250de42b5 100644
--- a/lapack-netlib/SRC/zgehd2.f
+++ b/lapack-netlib/SRC/zgehd2.f
@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
-*> \htmlonly
*> Download ZGEHD2 + dependencies
*>
*> [TGZ]
@@ -13,7 +12,6 @@
*> [ZIP]
*>
*> [TXT]
-*> \endhtmlonly
*
* Definition:
* ===========
@@ -106,7 +104,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \ingroup complex16GEcomputational
+*> \ingroup gehd2
*
*> \par Further Details:
* =====================
@@ -146,6 +144,7 @@
*>
* =====================================================================
SUBROUTINE ZGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO )
+ IMPLICIT NONE
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
@@ -166,10 +165,9 @@ SUBROUTINE ZGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO )
* ..
* .. Local Scalars ..
INTEGER I
- COMPLEX*16 ALPHA
* ..
* .. External Subroutines ..
- EXTERNAL XERBLA, ZLARF, ZLARFG
+ EXTERNAL XERBLA, ZLARF1F, ZLARFG
* ..
* .. Intrinsic Functions ..
INTRINSIC DCONJG, MAX, MIN
@@ -197,21 +195,19 @@ SUBROUTINE ZGEHD2( 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 ZLARFG( IHI-I, ALPHA, A( MIN( I+2, N ), I ), 1, TAU( I ) )
- A( I+1, I ) = ONE
+ CALL ZLARFG( IHI-I, A( I+1, I ), A( MIN( I+2, N ), I ), 1,
+ $ TAU( I ) )
*
* Apply H(i) to A(1:ihi,i+1:ihi) from the right
*
- CALL ZLARF( 'Right', IHI, IHI-I, A( I+1, I ), 1, TAU( I ),
- $ A( 1, I+1 ), LDA, WORK )
+ CALL ZLARF1F( '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 ZLARF( 'Left', IHI-I, N-I, A( I+1, I ), 1,
- $ DCONJG( TAU( I ) ), A( I+1, I+1 ), LDA, WORK )
+ CALL ZLARF1F( '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
diff --git a/lapack-netlib/SRC/zgelq2.f b/lapack-netlib/SRC/zgelq2.f
index 7604556a5f..19bac3142d 100644
--- a/lapack-netlib/SRC/zgelq2.f
+++ b/lapack-netlib/SRC/zgelq2.f
@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
-*> \htmlonly
*> Download ZGELQ2 + dependencies
*>
*> [TGZ]
@@ -13,7 +12,6 @@
*> [ZIP]
*>
*> [TXT]
-*> \endhtmlonly
*
* Definition:
* ===========
@@ -104,7 +102,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \ingroup complex16GEcomputational
+*> \ingroup gelq2
*
*> \par Further Details:
* =====================
@@ -126,6 +124,7 @@
*>
* =====================================================================
SUBROUTINE ZGELQ2( M, N, A, LDA, TAU, WORK, INFO )
+ IMPLICIT NONE
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
@@ -146,10 +145,9 @@ SUBROUTINE ZGELQ2( M, N, A, LDA, TAU, WORK, INFO )
* ..
* .. Local Scalars ..
INTEGER I, K
- COMPLEX*16 ALPHA
* ..
* .. External Subroutines ..
- EXTERNAL XERBLA, ZLACGV, ZLARF, ZLARFG
+ EXTERNAL XERBLA, ZLACGV, ZLARF1F, ZLARFG
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
@@ -178,18 +176,16 @@ SUBROUTINE ZGELQ2( M, N, A, LDA, TAU, WORK, INFO )
* Generate elementary reflector H(i) to annihilate A(i,i+1:n)
*
CALL ZLACGV( N-I+1, A( I, I ), LDA )
- ALPHA = A( I, I )
- CALL ZLARFG( N-I+1, ALPHA, A( I, MIN( I+1, N ) ), LDA,
+ CALL ZLARFG( 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 ZLARF( 'Right', M-I, N-I+1, A( I, I ), LDA, TAU( I ),
- $ A( I+1, I ), LDA, WORK )
+ CALL ZLARF1F( '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 ZLACGV( N-I+1, A( I, I ), LDA )
10 CONTINUE
RETURN
diff --git a/lapack-netlib/SRC/zgeql2.f b/lapack-netlib/SRC/zgeql2.f
index 35bd61d412..6cd9afe8cb 100644
--- a/lapack-netlib/SRC/zgeql2.f
+++ b/lapack-netlib/SRC/zgeql2.f
@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
-*> \htmlonly
*> Download ZGEQL2 + dependencies
*>
*> [TGZ]
@@ -13,7 +12,6 @@
*> [ZIP]
*>
*> [TXT]
-*> \endhtmlonly
*
* Definition:
* ===========
@@ -98,7 +96,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \ingroup complex16GEcomputational
+*> \ingroup geql2
*
*> \par Further Details:
* =====================
@@ -120,6 +118,7 @@
*>
* =====================================================================
SUBROUTINE ZGEQL2( M, N, A, LDA, TAU, WORK, INFO )
+ IMPLICIT NONE
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
@@ -140,10 +139,9 @@ SUBROUTINE ZGEQL2( M, N, A, LDA, TAU, WORK, INFO )
* ..
* .. Local Scalars ..
INTEGER I, K
- COMPLEX*16 ALPHA
* ..
* .. External Subroutines ..
- EXTERNAL XERBLA, ZLARF, ZLARFG
+ EXTERNAL XERBLA, ZLARF1L, ZLARFG
* ..
* .. Intrinsic Functions ..
INTRINSIC DCONJG, MAX, MIN
@@ -172,15 +170,13 @@ SUBROUTINE ZGEQL2( 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 ZLARFG( M-K+I, ALPHA, A( 1, N-K+I ), 1, TAU( I ) )
+ CALL ZLARFG( 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 ZLARF( 'Left', M-K+I, N-K+I-1, A( 1, N-K+I ), 1,
- $ DCONJG( TAU( I ) ), A, LDA, WORK )
- A( M-K+I, N-K+I ) = ALPHA
+ CALL ZLARF1L( 'Left', M-K+I, N-K+I-1, A( 1, N-K+I ), 1,
+ $ CONJG( TAU( I ) ), A, LDA, WORK )
10 CONTINUE
RETURN
*
diff --git a/lapack-netlib/SRC/zgeqp3rk.f b/lapack-netlib/SRC/zgeqp3rk.f
index f637966c8d..989ce69cc7 100644
--- a/lapack-netlib/SRC/zgeqp3rk.f
+++ b/lapack-netlib/SRC/zgeqp3rk.f
@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
-*> \htmlonly
*> Download ZGEQP3RK + dependencies
*>
*> [TGZ]
@@ -13,7 +12,6 @@
*> [ZIP]
*>
*> [TXT]
-*> \endhtmlonly
*
* Definition:
* ===========
@@ -552,27 +550,19 @@
*> C. H. Bischof, Math. and Comp. Sci. Div., Argonne National Lab, USA.
*> A BLAS-3 version of the QR factorization with column pivoting.
*> LAPACK Working Note 114
-*> \htmlonly
*> https://www.netlib.org/lapack/lawnspdf/lawn114.pdf
-*> \endhtmlonly
*> and in
*> SIAM J. Sci. Comput., 19(5):1486-1494, Sept. 1998.
-*> \htmlonly
*> https://doi.org/10.1137/S1064827595296732
-*> \endhtmlonly
*>
*> [2] A partial column norm updating strategy developed in 2006.
*> Z. Drmac and Z. Bujanovic, Dept. of Math., University of Zagreb, Croatia.
*> On the failure of rank revealing QR factorization software – a case study.
*> LAPACK Working Note 176.
-*> \htmlonly
*> http://www.netlib.org/lapack/lawnspdf/lawn176.pdf
-*> \endhtmlonly
*> and in
*> ACM Trans. Math. Softw. 35, 2, Article 12 (July 2008), 28 pages.
-*> \htmlonly
*> https://doi.org/10.1145/1377612.1377616
-*> \endhtmlonly
*
*> \par Contributors:
* ==================
@@ -677,7 +667,7 @@ SUBROUTINE ZGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, A, LDA,
* Minimal workspace size in case of using only unblocked
* BLAS 2 code in ZLAQP2RK.
* 1) ZLAQP2RK: N+NRHS-1 to use in WORK array that is used
-* in ZLARF subroutine inside ZLAQP2RK to apply an
+* in ZLARF1F subroutine inside ZLAQP2RK to apply an
* elementary reflector from the left.
* TOTAL_WORK_SIZE = 3*N + NRHS - 1
*
@@ -693,7 +683,7 @@ SUBROUTINE ZGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, A, LDA,
* 1) ZGEQP3RK, ZLAQP2RK, ZLAQP3RK: 2*N to store full and
* partial column 2-norms.
* 2) ZLAQP2RK: N+NRHS-1 to use in WORK array that is used
-* in ZLARF subroutine to apply an elementary reflector
+* in ZLARF1F subroutine to apply an elementary reflector
* from the left.
* 3) ZLAQP3RK: NB*(N+NRHS) to use in the work array F that
* is used to apply a block reflector from
@@ -893,7 +883,8 @@ SUBROUTINE ZGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, A, LDA,
* Determine when to cross over from blocked to unblocked code.
* (for N less than NX, unblocked code should be used).
*
- NX = MAX( 0, ILAENV( IXOVER, 'ZGEQP3RK', ' ', M, N, -1, -1 ) )
+ NX = MAX( 0, ILAENV( IXOVER, 'ZGEQP3RK', ' ', M, N, -1,
+ $ -1 ) )
*
IF( NX.LT.MINMN ) THEN
*
diff --git a/lapack-netlib/SRC/zgeqr2.f b/lapack-netlib/SRC/zgeqr2.f
index 511a81ef8a..958e606b73 100644
--- a/lapack-netlib/SRC/zgeqr2.f
+++ b/lapack-netlib/SRC/zgeqr2.f
@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
-*> \htmlonly
*> Download ZGEQR2 + dependencies
*>
*> [TGZ]
@@ -13,7 +12,6 @@
*> [ZIP]
*>
*> [TXT]
-*> \endhtmlonly
*
* Definition:
* ===========
@@ -105,7 +103,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \ingroup complex16GEcomputational
+*> \ingroup geqr2
*
*> \par Further Details:
* =====================
@@ -127,6 +125,7 @@
*>
* =====================================================================
SUBROUTINE ZGEQR2( M, N, A, LDA, TAU, WORK, INFO )
+ IMPLICIT NONE
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
@@ -147,10 +146,9 @@ SUBROUTINE ZGEQR2( M, N, A, LDA, TAU, WORK, INFO )
* ..
* .. Local Scalars ..
INTEGER I, K
- COMPLEX*16 ALPHA
* ..
* .. External Subroutines ..
- EXTERNAL XERBLA, ZLARF, ZLARFG
+ EXTERNAL XERBLA, ZLARF1F, ZLARFG
* ..
* .. Intrinsic Functions ..
INTRINSIC DCONJG, MAX, MIN
@@ -184,11 +182,8 @@ SUBROUTINE ZGEQR2( 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 ZLARF( 'Left', M-I+1, N-I, A( I, I ), 1,
- $ DCONJG( TAU( I ) ), A( I, I+1 ), LDA, WORK )
- A( I, I ) = ALPHA
+ CALL ZLARF1F( 'Left', M-I+1, N-I, A( I, I ), 1,
+ $ CONJG( TAU( I ) ), A( I, I+1 ), LDA, WORK )
END IF
10 CONTINUE
RETURN
diff --git a/lapack-netlib/SRC/zgeqr2p.f b/lapack-netlib/SRC/zgeqr2p.f
index 136d75f85c..aef5a2b015 100644
--- a/lapack-netlib/SRC/zgeqr2p.f
+++ b/lapack-netlib/SRC/zgeqr2p.f
@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
-*> \htmlonly
*> Download ZGEQR2P + dependencies
*>
*> [TGZ]
@@ -13,7 +12,6 @@
*> [ZIP]
*>
*> [TXT]
-*> \endhtmlonly
*
* Definition:
* ===========
@@ -107,7 +105,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \ingroup complex16GEcomputational
+*> \ingroup geqr2p
*
*> \par Further Details:
* =====================
@@ -131,6 +129,7 @@
*>
* =====================================================================
SUBROUTINE ZGEQR2P( M, N, A, LDA, TAU, WORK, INFO )
+ IMPLICIT NONE
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
@@ -151,10 +150,9 @@ SUBROUTINE ZGEQR2P( M, N, A, LDA, TAU, WORK, INFO )
* ..
* .. Local Scalars ..
INTEGER I, K
- COMPLEX*16 ALPHA
* ..
* .. External Subroutines ..
- EXTERNAL XERBLA, ZLARF, ZLARFGP
+ EXTERNAL XERBLA, ZLARF1F, ZLARFGP
* ..
* .. Intrinsic Functions ..
INTRINSIC DCONJG, MAX, MIN
@@ -188,11 +186,8 @@ SUBROUTINE ZGEQR2P( 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 ZLARF( 'Left', M-I+1, N-I, A( I, I ), 1,
- $ DCONJG( TAU( I ) ), A( I, I+1 ), LDA, WORK )
- A( I, I ) = ALPHA
+ CALL ZLARF1F( 'Left', M-I+1, N-I, A( I, I ), 1,
+ $ CONJG( TAU( I ) ), A( I, I+1 ), LDA, WORK )
END IF
10 CONTINUE
RETURN
diff --git a/lapack-netlib/SRC/zgerq2.f b/lapack-netlib/SRC/zgerq2.f
index 8a987dd0a0..dbd33d6b16 100644
--- a/lapack-netlib/SRC/zgerq2.f
+++ b/lapack-netlib/SRC/zgerq2.f
@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
-*> \htmlonly
*> Download ZGERQ2 + dependencies
*>
*> [TGZ]
@@ -13,7 +12,6 @@
*> [ZIP]
*>
*> [TXT]
-*> \endhtmlonly
*
* Definition:
* ===========
@@ -98,7 +96,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \ingroup complex16GEcomputational
+*> \ingroup gerq2
*
*> \par Further Details:
* =====================
@@ -120,6 +118,7 @@
*>
* =====================================================================
SUBROUTINE ZGERQ2( M, N, A, LDA, TAU, WORK, INFO )
+ IMPLICIT NONE
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
@@ -140,10 +139,9 @@ SUBROUTINE ZGERQ2( M, N, A, LDA, TAU, WORK, INFO )
* ..
* .. Local Scalars ..
INTEGER I, K
- COMPLEX*16 ALPHA
* ..
* .. External Subroutines ..
- EXTERNAL XERBLA, ZLACGV, ZLARF, ZLARFG
+ EXTERNAL XERBLA, ZLACGV, ZLARF1L, ZLARFG
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
@@ -173,15 +171,13 @@ SUBROUTINE ZGERQ2( M, N, A, LDA, TAU, WORK, INFO )
* A(m-k+i,1:n-k+i-1)
*
CALL ZLACGV( N-K+I, A( M-K+I, 1 ), LDA )
- ALPHA = A( M-K+I, N-K+I )
- CALL ZLARFG( N-K+I, ALPHA, A( M-K+I, 1 ), LDA, TAU( I ) )
+ CALL ZLARFG( 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 ZLARF( '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 ZLARF1L( 'Right', M-K+I-1, N-K+I, A( M-K+I, 1 ), LDA,
+ $ TAU( I ), A, LDA, WORK )
CALL ZLACGV( N-K+I-1, A( M-K+I, 1 ), LDA )
10 CONTINUE
RETURN
diff --git a/lapack-netlib/SRC/zlaqp2.f b/lapack-netlib/SRC/zlaqp2.f
index 2354b67887..bc81b28c26 100644
--- a/lapack-netlib/SRC/zlaqp2.f
+++ b/lapack-netlib/SRC/zlaqp2.f
@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
-*> \htmlonly
*> Download ZLAQP2 + dependencies
*>
*> [TGZ]
@@ -13,7 +12,6 @@
*> [ZIP]
*>
*> [TXT]
-*> \endhtmlonly
*
* Definition:
* ===========
@@ -122,7 +120,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \ingroup complex16OTHERauxiliary
+*> \ingroup laqp2
*
*> \par Contributors:
* ==================
@@ -139,13 +137,12 @@
*>
*> LAPACK Working Note 176
*
-*> \htmlonly
*> [PDF]
-*> \endhtmlonly
*
* =====================================================================
SUBROUTINE ZLAQP2( M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2,
$ WORK )
+ IMPLICIT NONE
*
* -- LAPACK auxiliary routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
@@ -171,10 +168,9 @@ SUBROUTINE ZLAQP2( M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2,
* .. Local Scalars ..
INTEGER I, ITEMP, J, MN, OFFPI, PVT
DOUBLE PRECISION TEMP, TEMP2, TOL3Z
- COMPLEX*16 AII
* ..
* .. External Subroutines ..
- EXTERNAL ZLARF, ZLARFG, ZSWAP
+ EXTERNAL ZLARF1F, ZLARFG, ZSWAP
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DCONJG, MAX, MIN, SQRT
@@ -211,7 +207,8 @@ SUBROUTINE ZLAQP2( M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2,
* Generate elementary reflector H(i).
*
IF( OFFPI.LT.M ) THEN
- CALL ZLARFG( M-OFFPI+1, A( OFFPI, I ), A( OFFPI+1, I ), 1,
+ CALL ZLARFG( M-OFFPI+1, A( OFFPI, I ), A( OFFPI+1, I ),
+ $ 1,
$ TAU( I ) )
ELSE
CALL ZLARFG( 1, A( M, I ), A( M, I ), 1, TAU( I ) )
@@ -221,12 +218,9 @@ SUBROUTINE ZLAQP2( M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2,
*
* Apply H(i)**H to A(offset+i:m,i+1:n) from the left.
*
- AII = A( OFFPI, I )
- A( OFFPI, I ) = CONE
- CALL ZLARF( 'Left', M-OFFPI+1, N-I, A( OFFPI, I ), 1,
- $ DCONJG( TAU( I ) ), A( OFFPI, I+1 ), LDA,
- $ WORK( 1 ) )
- A( OFFPI, I ) = AII
+ CALL ZLARF1F( 'Left', M-OFFPI+1, N-I, A( OFFPI, I ), 1,
+ $ CONJG( TAU( I ) ), A( OFFPI, I+1 ), LDA,
+ $ WORK( 1 ) )
END IF
*
* Update partial column norms.
diff --git a/lapack-netlib/SRC/zlaqp2rk.f b/lapack-netlib/SRC/zlaqp2rk.f
index f6bf555c26..0e0133ecfc 100644
--- a/lapack-netlib/SRC/zlaqp2rk.f
+++ b/lapack-netlib/SRC/zlaqp2rk.f
@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
-*> \htmlonly
*> Download ZLAQP2RK + dependencies
*>
*> [TGZ]
@@ -13,7 +12,6 @@
*> [ZIP]
*>
*> [TXT]
-*> \endhtmlonly
*
* Definition:
* ===========
@@ -254,7 +252,7 @@
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension (N-1)
-*> Used in ZLARF subroutine to apply an elementary
+*> Used in ZLARF1F subroutine to apply an elementary
*> reflector from the left.
*> \endverbatim
*>
@@ -304,27 +302,19 @@
*> C. H. Bischof, Math. and Comp. Sci. Div., Argonne National Lab, USA.
*> A BLAS-3 version of the QR factorization with column pivoting.
*> LAPACK Working Note 114
-*> \htmlonly
*> https://www.netlib.org/lapack/lawnspdf/lawn114.pdf
-*> \endhtmlonly
*> and in
*> SIAM J. Sci. Comput., 19(5):1486-1494, Sept. 1998.
-*> \htmlonly
*> https://doi.org/10.1137/S1064827595296732
-*> \endhtmlonly
*>
*> [2] A partial column norm updating strategy developed in 2006.
*> Z. Drmac and Z. Bujanovic, Dept. of Math., University of Zagreb, Croatia.
*> On the failure of rank revealing QR factorization software – a case study.
*> LAPACK Working Note 176.
-*> \htmlonly
*> http://www.netlib.org/lapack/lawnspdf/lawn176.pdf
-*> \endhtmlonly
*> and in
*> ACM Trans. Math. Softw. 35, 2, Article 12 (July 2008), 28 pages.
-*> \htmlonly
*> https://doi.org/10.1145/1377612.1377616
-*> \endhtmlonly
*
*> \par Contributors:
* ==================
@@ -369,13 +359,12 @@ SUBROUTINE ZLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL,
$ CONE = ( 1.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
- INTEGER I, ITEMP, J, JMAXC2NRM, KK, KP, MINMNFACT,
- $ MINMNUPDT
+ INTEGER I, ITEMP, J, JMAXC2NRM, KK, KP,
+ $ KBOUND, MINMNFACT, MINMNUPDT
DOUBLE PRECISION HUGEVAL, TAUNAN, TEMP, TEMP2, TOL3Z
- COMPLEX*16 AIKK
* ..
* .. External Subroutines ..
- EXTERNAL ZLARF, ZLARFG, ZSWAP
+ EXTERNAL ZLARF1F, ZLARFG, ZSWAP
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, DCONJG, DIMAG, MAX, MIN, SQRT
@@ -402,13 +391,13 @@ SUBROUTINE ZLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL,
*
MINMNFACT = MIN( M-IOFFSET, N )
MINMNUPDT = MIN( M-IOFFSET, N+NRHS )
- KMAX = MIN( KMAX, MINMNFACT )
+ KBOUND = MIN( KMAX, MINMNFACT )
TOL3Z = SQRT( DLAMCH( 'Epsilon' ) )
HUGEVAL = DLAMCH( 'Overflow' )
*
* Compute the factorization, KK is the lomn loop index.
*
- DO KK = 1, KMAX
+ DO KK = 1, KBOUND
*
I = IOFFSET + KK
*
@@ -633,12 +622,9 @@ SUBROUTINE ZLAQP2RK( 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 ) = CONE
- CALL ZLARF( 'Left', M-I+1, N+NRHS-KK, A( I, KK ), 1,
- $ DCONJG( TAU( KK ) ), A( I, KK+1 ), LDA,
- $ WORK( 1 ) )
- A( I, KK ) = AIKK
+ CALL ZLARF1F( 'Left', M-I+1, N+NRHS-KK, A( I, KK ), 1,
+ $ CONJG( TAU( KK ) ), A( I, KK+1 ), LDA,
+ $ WORK( 1 ) )
END IF
*
IF( KK.LT.MINMNFACT ) THEN
@@ -689,7 +675,7 @@ SUBROUTINE ZLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL,
* i.e. no condition was triggered to exit the routine.
* Set the number of factorized columns.
*
- K = KMAX
+ K = KBOUND
*
* We reached the end of the loop, i.e. all KMAX columns were
* factorized, we need to set MAXC2NRMK and RELMAXC2NRMK before
diff --git a/lapack-netlib/SRC/zlaqr2.f b/lapack-netlib/SRC/zlaqr2.f
index f78ea206dd..5cab69b91c 100644
--- a/lapack-netlib/SRC/zlaqr2.f
+++ b/lapack-netlib/SRC/zlaqr2.f
@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
-*> \htmlonly
*> Download ZLAQR2 + dependencies
*>
*> [TGZ]
@@ -13,7 +12,6 @@
*> [ZIP]
*>
*> [TXT]
-*> \endhtmlonly
*
* Definition:
* ===========
@@ -255,7 +253,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \ingroup complex16OTHERauxiliary
+*> \ingroup laqr2
*
*> \par Contributors:
* ==================
@@ -264,9 +262,11 @@
*> University of Kansas, USA
*>
* =====================================================================
- SUBROUTINE ZLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
+ SUBROUTINE ZLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH,
+ $ ILOZ,
$ IHIZ, Z, LDZ, NS, ND, SH, V, LDV, NH, T, LDT,
$ NV, WV, LDWV, WORK, LWORK )
+ IMPLICIT NONE
*
* -- LAPACK auxiliary routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
@@ -292,7 +292,7 @@ SUBROUTINE ZLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
PARAMETER ( RZERO = 0.0d0, RONE = 1.0d0 )
* ..
* .. Local Scalars ..
- COMPLEX*16 BETA, CDUM, S, TAU
+ COMPLEX*16 CDUM, S, TAU
DOUBLE PRECISION FOO, SAFMAX, SAFMIN, SMLNUM, ULP
INTEGER I, IFST, ILST, INFO, INFQR, J, JW, KCOL, KLN,
$ KNT, KROW, KWTOP, LTOP, LWK1, LWK2, LWKOPT
@@ -302,8 +302,9 @@ SUBROUTINE ZLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
EXTERNAL DLAMCH
* ..
* .. External Subroutines ..
- EXTERNAL DLABAD, ZCOPY, ZGEHRD, ZGEMM, ZLACPY, ZLAHQR,
- $ ZLARF, ZLARFG, ZLASET, ZTREXC, ZUNMHR
+ EXTERNAL ZCOPY, ZGEHRD, ZGEMM, ZLACPY,
+ $ ZLAHQR,
+ $ ZLARF1F, ZLARFG, ZLASET, ZTREXC, ZUNMHR
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, DCMPLX, DCONJG, DIMAG, INT, MAX, MIN
@@ -330,7 +331,8 @@ SUBROUTINE ZLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
*
* ==== Workspace query call to ZUNMHR ====
*
- CALL ZUNMHR( 'R', 'N', JW, JW, 1, JW-1, T, LDT, WORK, V, LDV,
+ CALL ZUNMHR( 'R', 'N', JW, JW, 1, JW-1, T, LDT, WORK, V,
+ $ LDV,
$ WORK, -1, INFO )
LWK2 = INT( WORK( 1 ) )
*
@@ -361,7 +363,6 @@ SUBROUTINE ZLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
*
SAFMIN = DLAMCH( 'SAFE MINIMUM' )
SAFMAX = RONE / SAFMIN
- CALL DLABAD( SAFMIN, SAFMAX )
ULP = DLAMCH( 'PRECISION' )
SMLNUM = SAFMIN*( DBLE( N ) / ULP )
*
@@ -400,7 +401,8 @@ SUBROUTINE ZLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
* . here and there to keep track.) ====
*
CALL ZLACPY( 'U', JW, JW, H( KWTOP, KWTOP ), LDH, T, LDT )
- CALL ZCOPY( JW-1, H( KWTOP+1, KWTOP ), LDH+1, T( 2, 1 ), LDT+1 )
+ CALL ZCOPY( JW-1, H( KWTOP+1, KWTOP ), LDH+1, T( 2, 1 ),
+ $ LDT+1 )
*
CALL ZLASET( 'A', JW, JW, ZERO, ONE, V, LDV )
CALL ZLAHQR( .true., .true., JW, 1, JW, T, LDT, SH( KWTOP ), 1,
@@ -452,7 +454,8 @@ SUBROUTINE ZLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
20 CONTINUE
ILST = I
IF( IFST.NE.ILST )
- $ CALL ZTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, INFO )
+ $ CALL ZTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST,
+ $ INFO )
30 CONTINUE
END IF
*
@@ -472,18 +475,17 @@ SUBROUTINE ZLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
DO 50 I = 1, NS
WORK( I ) = DCONJG( WORK( I ) )
50 CONTINUE
- BETA = WORK( 1 )
- CALL ZLARFG( NS, BETA, WORK( 2 ), 1, TAU )
- WORK( 1 ) = ONE
+ CALL ZLARFG( NS, WORK( 1 ), WORK( 2 ), 1, TAU )
*
- CALL ZLASET( 'L', JW-2, JW-2, ZERO, ZERO, T( 3, 1 ), LDT )
+ CALL ZLASET( 'L', JW-2, JW-2, ZERO, ZERO, T( 3, 1 ),
+ $ LDT )
*
- CALL ZLARF( 'L', NS, JW, WORK, 1, DCONJG( TAU ), T, LDT,
- $ WORK( JW+1 ) )
- CALL ZLARF( 'R', NS, NS, WORK, 1, TAU, T, LDT,
- $ WORK( JW+1 ) )
- CALL ZLARF( 'R', JW, NS, WORK, 1, TAU, V, LDV,
- $ WORK( JW+1 ) )
+ CALL ZLARF1F( 'L', NS, JW, WORK, 1, CONJG( TAU ), T, LDT,
+ $ WORK( JW+1 ) )
+ CALL ZLARF1F( 'R', NS, NS, WORK, 1, TAU, T, LDT,
+ $ WORK( JW+1 ) )
+ CALL ZLARF1F( 'R', JW, NS, WORK, 1, TAU, V, LDV,
+ $ WORK( JW+1 ) )
*
CALL ZGEHRD( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ),
$ LWORK-JW, INFO )
@@ -501,7 +503,8 @@ SUBROUTINE ZLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
* . H and Z, if requested. ====
*
IF( NS.GT.1 .AND. S.NE.ZERO )
- $ CALL ZUNMHR( 'R', 'N', JW, NS, 1, NS, T, LDT, WORK, V, LDV,
+ $ CALL ZUNMHR( 'R', 'N', JW, NS, 1, NS, T, LDT, WORK, V,
+ $ LDV,
$ WORK( JW+1 ), LWORK-JW, INFO )
*
* ==== Update vertical slab in H ====
@@ -515,7 +518,8 @@ SUBROUTINE ZLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
KLN = MIN( NV, KWTOP-KROW )
CALL ZGEMM( 'N', 'N', KLN, JW, JW, ONE, H( KROW, KWTOP ),
$ LDH, V, LDV, ZERO, WV, LDWV )
- CALL ZLACPY( 'A', KLN, JW, WV, LDWV, H( KROW, KWTOP ), LDH )
+ CALL ZLACPY( 'A', KLN, JW, WV, LDWV, H( KROW, KWTOP ),
+ $ LDH )
60 CONTINUE
*
* ==== Update horizontal slab in H ====
@@ -535,7 +539,8 @@ SUBROUTINE ZLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
IF( WANTZ ) THEN
DO 80 KROW = ILOZ, IHIZ, NV
KLN = MIN( NV, IHIZ-KROW+1 )
- CALL ZGEMM( 'N', 'N', KLN, JW, JW, ONE, Z( KROW, KWTOP ),
+ CALL ZGEMM( 'N', 'N', KLN, JW, JW, ONE, Z( KROW,
+ $ KWTOP ),
$ LDZ, V, LDV, ZERO, WV, LDWV )
CALL ZLACPY( 'A', KLN, JW, WV, LDWV, Z( KROW, KWTOP ),
$ LDZ )
diff --git a/lapack-netlib/SRC/zlaqr3.f b/lapack-netlib/SRC/zlaqr3.f
index c8e5fe9996..9a696fe115 100644
--- a/lapack-netlib/SRC/zlaqr3.f
+++ b/lapack-netlib/SRC/zlaqr3.f
@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
-*> \htmlonly
*> Download ZLAQR3 + dependencies
*>
*> [TGZ]
@@ -13,7 +12,6 @@
*> [ZIP]
*>
*> [TXT]
-*> \endhtmlonly
*
* Definition:
* ===========
@@ -252,7 +250,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \ingroup complex16OTHERauxiliary
+*> \ingroup laqr3
*
*> \par Contributors:
* ==================
@@ -261,9 +259,11 @@
*> University of Kansas, USA
*>
* =====================================================================
- SUBROUTINE ZLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
+ SUBROUTINE ZLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH,
+ $ ILOZ,
$ IHIZ, Z, LDZ, NS, ND, SH, V, LDV, NH, T, LDT,
$ NV, WV, LDWV, WORK, LWORK )
+ IMPLICIT NONE
*
* -- LAPACK auxiliary routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
@@ -289,7 +289,7 @@ SUBROUTINE ZLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
PARAMETER ( RZERO = 0.0d0, RONE = 1.0d0 )
* ..
* .. Local Scalars ..
- COMPLEX*16 BETA, CDUM, S, TAU
+ COMPLEX*16 CDUM, S, TAU
DOUBLE PRECISION FOO, SAFMAX, SAFMIN, SMLNUM, ULP
INTEGER I, IFST, ILST, INFO, INFQR, J, JW, KCOL, KLN,
$ KNT, KROW, KWTOP, LTOP, LWK1, LWK2, LWK3,
@@ -301,8 +301,9 @@ SUBROUTINE ZLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
EXTERNAL DLAMCH, ILAENV
* ..
* .. External Subroutines ..
- EXTERNAL DLABAD, ZCOPY, ZGEHRD, ZGEMM, ZLACPY, ZLAHQR,
- $ ZLAQR4, ZLARF, ZLARFG, ZLASET, ZTREXC, ZUNMHR
+ EXTERNAL ZCOPY, ZGEHRD, ZGEMM, ZLACPY, ZLAHQR,
+ $ ZLAQR4,
+ $ ZLARF1F, ZLARFG, ZLASET, ZTREXC, ZUNMHR
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, DCMPLX, DCONJG, DIMAG, INT, MAX, MIN
@@ -329,13 +330,15 @@ SUBROUTINE ZLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
*
* ==== Workspace query call to ZUNMHR ====
*
- CALL ZUNMHR( 'R', 'N', JW, JW, 1, JW-1, T, LDT, WORK, V, LDV,
+ CALL ZUNMHR( 'R', 'N', JW, JW, 1, JW-1, T, LDT, WORK, V,
+ $ LDV,
$ WORK, -1, INFO )
LWK2 = INT( WORK( 1 ) )
*
* ==== Workspace query call to ZLAQR4 ====
*
- CALL ZLAQR4( .true., .true., JW, 1, JW, T, LDT, SH, 1, JW, V,
+ CALL ZLAQR4( .true., .true., JW, 1, JW, T, LDT, SH, 1, JW,
+ $ V,
$ LDV, WORK, -1, INFQR )
LWK3 = INT( WORK( 1 ) )
*
@@ -366,7 +369,6 @@ SUBROUTINE ZLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
*
SAFMIN = DLAMCH( 'SAFE MINIMUM' )
SAFMAX = RONE / SAFMIN
- CALL DLABAD( SAFMIN, SAFMAX )
ULP = DLAMCH( 'PRECISION' )
SMLNUM = SAFMIN*( DBLE( N ) / ULP )
*
@@ -405,15 +407,18 @@ SUBROUTINE ZLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
* . here and there to keep track.) ====
*
CALL ZLACPY( 'U', JW, JW, H( KWTOP, KWTOP ), LDH, T, LDT )
- CALL ZCOPY( JW-1, H( KWTOP+1, KWTOP ), LDH+1, T( 2, 1 ), LDT+1 )
+ CALL ZCOPY( JW-1, H( KWTOP+1, KWTOP ), LDH+1, T( 2, 1 ),
+ $ LDT+1 )
*
CALL ZLASET( 'A', JW, JW, ZERO, ONE, V, LDV )
NMIN = ILAENV( 12, 'ZLAQR3', 'SV', JW, 1, JW, LWORK )
IF( JW.GT.NMIN ) THEN
- CALL ZLAQR4( .true., .true., JW, 1, JW, T, LDT, SH( KWTOP ), 1,
+ CALL ZLAQR4( .true., .true., JW, 1, JW, T, LDT, SH( KWTOP ),
+ $ 1,
$ JW, V, LDV, WORK, LWORK, INFQR )
ELSE
- CALL ZLAHQR( .true., .true., JW, 1, JW, T, LDT, SH( KWTOP ), 1,
+ CALL ZLAHQR( .true., .true., JW, 1, JW, T, LDT, SH( KWTOP ),
+ $ 1,
$ JW, V, LDV, INFQR )
END IF
*
@@ -463,7 +468,8 @@ SUBROUTINE ZLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
20 CONTINUE
ILST = I
IF( IFST.NE.ILST )
- $ CALL ZTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, INFO )
+ $ CALL ZTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST,
+ $ INFO )
30 CONTINUE
END IF
*
@@ -483,18 +489,17 @@ SUBROUTINE ZLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
DO 50 I = 1, NS
WORK( I ) = DCONJG( WORK( I ) )
50 CONTINUE
- BETA = WORK( 1 )
- CALL ZLARFG( NS, BETA, WORK( 2 ), 1, TAU )
- WORK( 1 ) = ONE
+ CALL ZLARFG( NS, WORK( 1 ), WORK( 2 ), 1, TAU )
*
- CALL ZLASET( 'L', JW-2, JW-2, ZERO, ZERO, T( 3, 1 ), LDT )
+ CALL ZLASET( 'L', JW-2, JW-2, ZERO, ZERO, T( 3, 1 ),
+ $ LDT )
*
- CALL ZLARF( 'L', NS, JW, WORK, 1, DCONJG( TAU ), T, LDT,
- $ WORK( JW+1 ) )
- CALL ZLARF( 'R', NS, NS, WORK, 1, TAU, T, LDT,
- $ WORK( JW+1 ) )
- CALL ZLARF( 'R', JW, NS, WORK, 1, TAU, V, LDV,
- $ WORK( JW+1 ) )
+ CALL ZLARF1F( 'L', NS, JW, WORK, 1, CONJG( TAU ), T, LDT,
+ $ WORK( JW+1 ) )
+ CALL ZLARF1F( 'R', NS, NS, WORK, 1, TAU, T, LDT,
+ $ WORK( JW+1 ) )
+ CALL ZLARF1F( 'R', JW, NS, WORK, 1, TAU, V, LDV,
+ $ WORK( JW+1 ) )
*
CALL ZGEHRD( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ),
$ LWORK-JW, INFO )
@@ -512,7 +517,8 @@ SUBROUTINE ZLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
* . H and Z, if requested. ====
*
IF( NS.GT.1 .AND. S.NE.ZERO )
- $ CALL ZUNMHR( 'R', 'N', JW, NS, 1, NS, T, LDT, WORK, V, LDV,
+ $ CALL ZUNMHR( 'R', 'N', JW, NS, 1, NS, T, LDT, WORK, V,
+ $ LDV,
$ WORK( JW+1 ), LWORK-JW, INFO )
*
* ==== Update vertical slab in H ====
@@ -526,7 +532,8 @@ SUBROUTINE ZLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
KLN = MIN( NV, KWTOP-KROW )
CALL ZGEMM( 'N', 'N', KLN, JW, JW, ONE, H( KROW, KWTOP ),
$ LDH, V, LDV, ZERO, WV, LDWV )
- CALL ZLACPY( 'A', KLN, JW, WV, LDWV, H( KROW, KWTOP ), LDH )
+ CALL ZLACPY( 'A', KLN, JW, WV, LDWV, H( KROW, KWTOP ),
+ $ LDH )
60 CONTINUE
*
* ==== Update horizontal slab in H ====
@@ -546,7 +553,8 @@ SUBROUTINE ZLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
IF( WANTZ ) THEN
DO 80 KROW = ILOZ, IHIZ, NV
KLN = MIN( NV, IHIZ-KROW+1 )
- CALL ZGEMM( 'N', 'N', KLN, JW, JW, ONE, Z( KROW, KWTOP ),
+ CALL ZGEMM( 'N', 'N', KLN, JW, JW, ONE, Z( KROW,
+ $ KWTOP ),
$ LDZ, V, LDV, ZERO, WV, LDWV )
CALL ZLACPY( 'A', KLN, JW, WV, LDWV, Z( KROW, KWTOP ),
$ LDZ )
diff --git a/lapack-netlib/SRC/zlarf1f.c b/lapack-netlib/SRC/zlarf1f.c
new file mode 100644
index 0000000000..fa7f345820
--- /dev/null
+++ b/lapack-netlib/SRC/zlarf1f.c
@@ -0,0 +1,590 @@
+#include
+#include
+#include
+#include
+#include
+#ifdef complex
+#undef complex
+#endif
+#ifdef I
+#undef I
+#endif
+
+#if defined(_WIN64)
+typedef long long BLASLONG;
+typedef unsigned long long BLASULONG;
+#else
+typedef long BLASLONG;
+typedef unsigned long BLASULONG;
+#endif
+
+#ifdef LAPACK_ILP64
+typedef BLASLONG blasint;
+#if defined(_WIN64)
+#define blasabs(x) llabs(x)
+#else
+#define blasabs(x) labs(x)
+#endif
+#else
+typedef int blasint;
+#define blasabs(x) abs(x)
+#endif
+
+typedef blasint integer;
+
+typedef unsigned int uinteger;
+typedef char *address;
+typedef short int shortint;
+typedef float real;
+typedef double doublereal;
+typedef struct { real r, i; } complex;
+typedef struct { doublereal r, i; } doublecomplex;
+#ifdef _MSC_VER
+static inline _Fcomplex Cf(complex *z) {_Fcomplex zz={z->r , z->i}; return zz;}
+static inline _Dcomplex Cd(doublecomplex *z) {_Dcomplex zz={z->r , z->i};return zz;}
+static inline _Fcomplex * _pCf(complex *z) {return (_Fcomplex*)z;}
+static inline _Dcomplex * _pCd(doublecomplex *z) {return (_Dcomplex*)z;}
+#else
+static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;}
+static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;}
+static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;}
+static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;}
+#endif
+#define pCf(z) (*_pCf(z))
+#define pCd(z) (*_pCd(z))
+typedef int logical;
+typedef short int shortlogical;
+typedef char logical1;
+typedef char integer1;
+
+#define TRUE_ (1)
+#define FALSE_ (0)
+
+/* Extern is for use with -E */
+#ifndef Extern
+#define Extern extern
+#endif
+
+/* I/O stuff */
+
+typedef int flag;
+typedef int ftnlen;
+typedef int ftnint;
+
+/*external read, write*/
+typedef struct
+{ flag cierr;
+ ftnint ciunit;
+ flag ciend;
+ char *cifmt;
+ ftnint cirec;
+} cilist;
+
+/*internal read, write*/
+typedef struct
+{ flag icierr;
+ char *iciunit;
+ flag iciend;
+ char *icifmt;
+ ftnint icirlen;
+ ftnint icirnum;
+} icilist;
+
+/*open*/
+typedef struct
+{ flag oerr;
+ ftnint ounit;
+ char *ofnm;
+ ftnlen ofnmlen;
+ char *osta;
+ char *oacc;
+ char *ofm;
+ ftnint orl;
+ char *oblnk;
+} olist;
+
+/*close*/
+typedef struct
+{ flag cerr;
+ ftnint cunit;
+ char *csta;
+} cllist;
+
+/*rewind, backspace, endfile*/
+typedef struct
+{ flag aerr;
+ ftnint aunit;
+} alist;
+
+/* inquire */
+typedef struct
+{ flag inerr;
+ ftnint inunit;
+ char *infile;
+ ftnlen infilen;
+ ftnint *inex; /*parameters in standard's order*/
+ ftnint *inopen;
+ ftnint *innum;
+ ftnint *innamed;
+ char *inname;
+ ftnlen innamlen;
+ char *inacc;
+ ftnlen inacclen;
+ char *inseq;
+ ftnlen inseqlen;
+ char *indir;
+ ftnlen indirlen;
+ char *infmt;
+ ftnlen infmtlen;
+ char *inform;
+ ftnint informlen;
+ char *inunf;
+ ftnlen inunflen;
+ ftnint *inrecl;
+ ftnint *innrec;
+ char *inblank;
+ ftnlen inblanklen;
+} inlist;
+
+#define VOID void
+
+union Multitype { /* for multiple entry points */
+ integer1 g;
+ shortint h;
+ integer i;
+ /* longint j; */
+ real r;
+ doublereal d;
+ complex c;
+ doublecomplex z;
+ };
+
+typedef union Multitype Multitype;
+
+struct Vardesc { /* for Namelist */
+ char *name;
+ char *addr;
+ ftnlen *dims;
+ int type;
+ };
+typedef struct Vardesc Vardesc;
+
+struct Namelist {
+ char *name;
+ Vardesc **vars;
+ int nvars;
+ };
+typedef struct Namelist Namelist;
+
+#define abs(x) ((x) >= 0 ? (x) : -(x))
+#define dabs(x) (fabs(x))
+#define f2cmin(a,b) ((a) <= (b) ? (a) : (b))
+#define f2cmax(a,b) ((a) >= (b) ? (a) : (b))
+#define dmin(a,b) (f2cmin(a,b))
+#define dmax(a,b) (f2cmax(a,b))
+#define bit_test(a,b) ((a) >> (b) & 1)
+#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b)))
+#define bit_set(a,b) ((a) | ((uinteger)1 << (b)))
+
+#define abort_() { sig_die("Fortran abort routine called", 1); }
+#define c_abs(z) (cabsf(Cf(z)))
+#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); }
+#ifdef _MSC_VER
+#define c_div(c, a, b) {Cf(c)._Val[0] = (Cf(a)._Val[0]/Cf(b)._Val[0]); Cf(c)._Val[1]=(Cf(a)._Val[1]/Cf(b)._Val[1]);}
+#define z_div(c, a, b) {Cd(c)._Val[0] = (Cd(a)._Val[0]/Cd(b)._Val[0]); Cd(c)._Val[1]=(Cd(a)._Val[1]/Cd(b)._Val[1]);}
+#else
+#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);}
+#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);}
+#endif
+#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));}
+#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));}
+#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));}
+//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));}
+#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));}
+#define d_abs(x) (fabs(*(x)))
+#define d_acos(x) (acos(*(x)))
+#define d_asin(x) (asin(*(x)))
+#define d_atan(x) (atan(*(x)))
+#define d_atn2(x, y) (atan2(*(x),*(y)))
+#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); }
+#define r_cnjg(R, Z) { pCf(R) = conjf(Cf(Z)); }
+#define d_cos(x) (cos(*(x)))
+#define d_cosh(x) (cosh(*(x)))
+#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 )
+#define d_exp(x) (exp(*(x)))
+#define d_imag(z) (cimag(Cd(z)))
+#define r_imag(z) (cimagf(Cf(z)))
+#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define d_log(x) (log(*(x)))
+#define d_mod(x, y) (fmod(*(x), *(y)))
+#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x)))
+#define d_nint(x) u_nint(*(x))
+#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a)))
+#define d_sign(a,b) u_sign(*(a),*(b))
+#define r_sign(a,b) u_sign(*(a),*(b))
+#define d_sin(x) (sin(*(x)))
+#define d_sinh(x) (sinh(*(x)))
+#define d_sqrt(x) (sqrt(*(x)))
+#define d_tan(x) (tan(*(x)))
+#define d_tanh(x) (tanh(*(x)))
+#define i_abs(x) abs(*(x))
+#define i_dnnt(x) ((integer)u_nint(*(x)))
+#define i_len(s, n) (n)
+#define i_nint(x) ((integer)u_nint(*(x)))
+#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b)))
+#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; }
+#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d))))
+#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
+#define sig_die(s, kill) { exit(1); }
+#define s_stop(s, n) {exit(0);}
+#define z_abs(z) (cabs(Cd(z)))
+#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
+#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
+
+/* procedure parameter types for -A and -C++ */
+
+#define F2C_proc_par_types 1
+#ifdef __cplusplus
+typedef logical (*L_fp)(...);
+#else
+typedef logical (*L_fp)();
+#endif
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {1.,0.};
+static doublecomplex c_b2 = {0.,0.};
+static integer c__1 = 1;
+
+/* > \brief \b ZLARF1F applies an elementary reflector to a general rectangular */
+/* matrix assuming v(1) = 1. */
+
+/* =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/* http://www.netlib.org/lapack/explore-html/ */
+
+/* > Download ZLARF1F + dependencies */
+/* > */
+/* > [TGZ] */
+/* > */
+/* > [ZIP] */
+/* > */
+/* > [TXT] */
+
+/* Definition: */
+/* =========== */
+
+/* SUBROUTINE ZLARF1F( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) */
+
+/* CHARACTER SIDE */
+/* INTEGER INCV, LDC, M, N */
+/* COMPLEX*16 TAU */
+/* COMPLEX*16 C( LDC, * ), V( * ), WORK( * ) */
+
+
+/* > \par Purpose: */
+/* ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > ZLARF1F applies a complex elementary reflector H to a real m by n matrix */
+/* > C, from either the left or the right. H is represented in the form */
+/* > */
+/* > H = I - tau * v * v**H */
+/* > */
+/* > where tau is a complex scalar and v is a complex vector. */
+/* > */
+/* > If tau = 0, then H is taken to be the unit matrix. */
+/* > */
+/* > To apply H**H, supply conjg(tau) instead */
+/* > tau. */
+/* > \endverbatim */
+
+/* Arguments: */
+/* ========== */
+
+/* > \param[in] SIDE */
+/* > \verbatim */
+/* > SIDE is CHARACTER*1 */
+/* > = 'L': form H * C */
+/* > */
+/* > \param[in] M */
+/* > \verbatim */
+/* > M is INTEGER */
+/* > The number of rows of the matrix C. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] N */
+/* > \verbatim */
+/* > N is INTEGER */
+/* > The number of columns of the matrix C. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] V */
+/* > \verbatim */
+/* > V is COMPLEX*16 array, dimension */
+/* > (1 + (M-1)*abs(INCV)) if SIDE = 'L' */
+/* > or (1 + (N-1)*abs(INCV)) if SIDE = 'R' */
+/* > The vector v in the representation of H. V is not used if */
+/* > TAU = 0. V(1) is not referenced or modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] INCV */
+/* > \verbatim */
+/* > INCV is INTEGER */
+/* > The increment between elements of v. INCV <> 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] TAU */
+/* > \verbatim */
+/* > TAU is COMPLEX*16 */
+/* > The value tau in the representation of H. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] C */
+/* > \verbatim */
+/* > C is COMPLEX*16 array, dimension (LDC,N) */
+/* > On entry, the m by n matrix C. */
+/* > On exit, C is overwritten by the matrix H * C if SIDE = 'L', */
+/* > or C * H if SIDE = 'R'. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDC */
+/* > \verbatim */
+/* > LDC is INTEGER */
+/* > The leading dimension of the array C. LDC >= f2cmax(1,M). */
+/* > \endverbatim */
+/* > */
+/* > \param[out] WORK */
+/* > \verbatim */
+/* > WORK is COMPLEX*16 array, dimension */
+/* > (N) if SIDE = 'L' */
+/* > or (M) if SIDE = 'R' */
+/* > \endverbatim */
+/* To take advantage of the fact that v(1) = 1, we do the following */
+/* v = [ 1 v_2 ]**T */
+/* If SIDE='L' */
+/* |-----| */
+/* | C_1 | */
+/* C =| C_2 | */
+/* |-----| */
+/* C_1\in\mathbb{C}^{1\times n}, C_2\in\mathbb{C}^{m-1\times n} */
+/* So we compute: */
+/* C = HC = (I - \tau vv**T)C */
+/* = C - \tau vv**T C */
+/* w = C**T v = [ C_1**T C_2**T ] [ 1 v_2 ]**T */
+/* = C_1**T + C_2**T v ( ZGEMM then ZAXPYC-like ) */
+/* C = C - \tau vv**T C */
+/* = C - \tau vw**T */
+/* Giving us C_1 = C_1 - \tau w**T ( ZAXPYC-like ) */
+/* and */
+/* C_2 = C_2 - \tau v_2w**T ( ZGERC ) */
+/* If SIDE='R' */
+
+/* C = [ C_1 C_2 ] */
+/* C_1\in\mathbb{C}^{m\times 1}, C_2\in\mathbb{C}^{m\times n-1} */
+/* So we compute: */
+/* C = CH = C(I - \tau vv**T) */
+/* = C - \tau Cvv**T */
+
+/* w = Cv = [ C_1 C_2 ] [ 1 v_2 ]**T */
+/* = C_1 + C_2v_2 ( ZGEMM then ZAXPYC-like ) */
+/* C = C - \tau Cvv**T */
+/* = C - \tau wv**T */
+/* Giving us C_1 = C_1 - \tau w ( ZAXPYC-like ) */
+/* and */
+/* C_2 = C_2 - \tau wv_2**T ( ZGERC ) */
+
+/* Authors: */
+/* ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \ingroup larf */
+
+/* ===================================================================== */
+/* Subroutine */ int zlarf1f_(char *side, integer *m, integer *n,
+ doublecomplex *v, integer *incv, doublecomplex *tau, doublecomplex *
+ c__, integer *ldc, doublecomplex *work)
+{
+ /* System generated locals */
+ integer c_dim1, c_offset, i__1, i__2, i__3;
+ doublecomplex z__1, z__2, z__3;
+
+ /* Local variables */
+ integer i__;
+ logical applyleft;
+ extern logical lsame_(char *, char *);
+ integer lastc;
+ extern /* Subroutine */ int zgerc_(integer *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), zscal_(integer *, doublecomplex *,
+ doublecomplex *, integer *), zgemv_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *);
+ integer lastv;
+ extern /* Subroutine */ int zaxpy_(integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ extern integer ilazlc_(integer *, integer *, doublecomplex *, integer *),
+ ilazlr_(integer *, integer *, doublecomplex *, integer *);
+
+
+/* -- LAPACK auxiliary routine -- */
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+
+
+/* ===================================================================== */
+
+
+ /* Parameter adjustments */
+ --v;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --work;
+
+ /* Function Body */
+ applyleft = lsame_(side, "L");
+ lastv = 1;
+ lastc = 0;
+ if (tau->r != 0. || tau->i != 0.) {
+/* Set up variables for scanning V. LASTV begins pointing to the end */
+/* of V. */
+ if (applyleft) {
+ lastv = *m;
+ } else {
+ lastv = *n;
+ }
+ if (*incv > 0) {
+ i__ = (lastv - 1) * *incv + 1;
+ } else {
+ i__ = 1;
+ }
+/* Look for the last non-zero row in V. */
+/* Since we are assuming that V(1) = 1, and it is not stored, so we */
+/* shouldn't access it. */
+ for(;;) { /* while(complicated condition) */
+ i__1 = i__;
+ if (!(lastv > 1 && (v[i__1].r == 0. && v[i__1].i == 0.)))
+ break;
+ --lastv;
+ i__ -= *incv;
+ }
+ if (applyleft) {
+/* Scan for the last non-zero column in C(1:lastv,:). */
+ lastc = ilazlc_(&lastv, n, &c__[c_offset], ldc);
+ } else {
+/* Scan for the last non-zero row in C(:,1:lastv). */
+ lastc = ilazlr_(m, &lastv, &c__[c_offset], ldc);
+ }
+ }
+ if (lastc == 0) {
+ return 0;
+ }
+ if (applyleft) {
+
+/* Form H * C */
+
+/* Check if m = 1. This means v = 1, So we just need to compu */
+/* C := HC = (1-\tau)C. */
+ if (lastv == 1) {
+ z__1.r = 1. - tau->r, z__1.i = 0. - tau->i;
+ zscal_(&lastc, &z__1, &c__[c_offset], ldc);
+ } else {
+
+/* w(1:lastc,1) := C(1:lastv,1:lastc)**H * v(1:lastv,1) */
+
+/* (I - tvv**H)C = C - tvv**H C */
+/* First compute w**H = v**H c -> w = C**H v */
+/* C = [ C_1 C_2 ]**T, v = [1 v_2]**T */
+/* w = C_1**H + C_2**Hv_2 */
+/* w = C_2**Hv_2 */
+ i__1 = lastv - 1;
+ zgemv_("Conjugate transpose", &i__1, &lastc, &c_b1, &c__[c_dim1 +
+ 2], ldc, &v[*incv + 1], incv, &c_b2, &work[1], &c__1);
+
+/* w(1:lastc,1) += v(1,1) * C(1,1:lastc)**H */
+
+ i__1 = lastc;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ d_cnjg(&z__2, &c__[i__ * c_dim1 + 1]);
+ z__1.r = work[i__3].r + z__2.r, z__1.i = work[i__3].i +
+ z__2.i;
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+ }
+
+/* C(1:lastv,1:lastc) := C(...) - tau * v(1:lastv,1) * w(1:lastc,1)**H */
+
+/* C(1, 1:lastc) := C(...) - tau * v(1,1) * w(1:lastc,1)**H */
+/* = C(...) - tau * Conj(w(1:lastc,1)) */
+/* This is essentially a zaxpyc */
+ i__1 = lastc;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ * c_dim1 + 1;
+ i__3 = i__ * c_dim1 + 1;
+ d_cnjg(&z__3, &work[i__]);
+ z__2.r = tau->r * z__3.r - tau->i * z__3.i, z__2.i = tau->r *
+ z__3.i + tau->i * z__3.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+ }
+
+/* C(2:lastv,1:lastc) += - tau * v(2:lastv,1) * w(1:lastc,1)**H */
+
+ i__1 = lastv - 1;
+ z__1.r = -tau->r, z__1.i = -tau->i;
+ zgerc_(&i__1, &lastc, &z__1, &v[*incv + 1], incv, &work[1], &c__1,
+ &c__[c_dim1 + 2], ldc);
+ }
+ } else {
+
+/* Form C * H */
+
+/* Check if n = 1. This means v = 1, so we just need to compu */
+/* C := CH = C(1-\tau). */
+ if (lastv == 1) {
+ z__1.r = 1. - tau->r, z__1.i = 0. - tau->i;
+ zscal_(&lastc, &z__1, &c__[c_offset], &c__1);
+ } else {
+
+/* w(1:lastc,1) := C(1:lastc,1:lastv) * v(1:lastv,1) */
+
+/* w(1:lastc,1) := C(1:lastc,2:lastv) * v(2:lastv,1) */
+ i__1 = lastv - 1;
+ zgemv_("No transpose", &lastc, &i__1, &c_b1, &c__[(c_dim1 << 1) +
+ 1], ldc, &v[*incv + 1], incv, &c_b2, &work[1], &c__1);
+/* w(1:lastc,1) += C(1:lastc,1) v(1,1) = C(1:lastc,1) */
+ zaxpy_(&lastc, &c_b1, &c__[c_offset], &c__1, &work[1], &c__1);
+
+/* C(1:lastc,1:lastv) := C(...) - tau * w(1:lastc,1) * v(1:lastv,1)**T */
+
+/* C(1:lastc,1) := C(...) - tau * w(1:lastc,1) * v(1,1 */
+/* = C(...) - tau * w(1:lastc,1) */
+ z__1.r = -tau->r, z__1.i = -tau->i;
+ zaxpy_(&lastc, &z__1, &work[1], &c__1, &c__[c_offset], &c__1);
+/* C(1:lastc,2:lastv) := C(...) - tau * w(1:lastc,1) * v(2 */
+ i__1 = lastv - 1;
+ z__1.r = -tau->r, z__1.i = -tau->i;
+ zgerc_(&lastc, &i__1, &z__1, &work[1], &c__1, &v[*incv + 1], incv,
+ &c__[(c_dim1 << 1) + 1], ldc);
+ }
+ }
+ return 0;
+
+/* End of ZLARF1F */
+
+} /* zlarf1f_ */
+
diff --git a/lapack-netlib/SRC/zlarf1f.f b/lapack-netlib/SRC/zlarf1f.f
new file mode 100644
index 0000000000..adaca3c9b4
--- /dev/null
+++ b/lapack-netlib/SRC/zlarf1f.f
@@ -0,0 +1,302 @@
+*> \brief \b ZLARF1F applies an elementary reflector to a general rectangular
+* matrix assuming v(1) = 1.
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> Download ZLARF1F + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZLARF1F( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )
+*
+* .. Scalar Arguments ..
+* CHARACTER SIDE
+* INTEGER INCV, LDC, M, N
+* COMPLEX*16 TAU
+* ..
+* .. Array Arguments ..
+* COMPLEX*16 C( LDC, * ), V( * ), WORK( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> ZLARF1F applies a complex elementary reflector H to a real m by n matrix
+*> C, from either the left or the right. H is represented in the form
+*>
+*> H = I - tau * v * v**H
+*>
+*> where tau is a complex scalar and v is a complex vector.
+*>
+*> If tau = 0, then H is taken to be the unit matrix.
+*>
+*> To apply H**H, supply conjg(tau) instead
+*> tau.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] SIDE
+*> \verbatim
+*> SIDE is CHARACTER*1
+*> = 'L': form H * C
+*>
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows of the matrix C.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of columns of the matrix C.
+*> \endverbatim
+*>
+*> \param[in] V
+*> \verbatim
+*> V is COMPLEX*16 array, dimension
+*> (1 + (M-1)*abs(INCV)) if SIDE = 'L'
+*> or (1 + (N-1)*abs(INCV)) if SIDE = 'R'
+*> The vector v in the representation of H. V is not used if
+*> TAU = 0. V(1) is not referenced or modified.
+*> \endverbatim
+*>
+*> \param[in] INCV
+*> \verbatim
+*> INCV is INTEGER
+*> The increment between elements of v. INCV <> 0.
+*> \endverbatim
+*>
+*> \param[in] TAU
+*> \verbatim
+*> TAU is COMPLEX*16
+*> The value tau in the representation of H.
+*> \endverbatim
+*>
+*> \param[in,out] C
+*> \verbatim
+*> C is COMPLEX*16 array, dimension (LDC,N)
+*> On entry, the m by n matrix C.
+*> On exit, C is overwritten by the matrix H * C if SIDE = 'L',
+*> or C * H if SIDE = 'R'.
+*> \endverbatim
+*>
+*> \param[in] LDC
+*> \verbatim
+*> LDC is INTEGER
+*> The leading dimension of the array C. LDC >= max(1,M).
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is COMPLEX*16 array, dimension
+*> (N) if SIDE = 'L'
+*> or (M) if SIDE = 'R'
+*> \endverbatim
+* To take advantage of the fact that v(1) = 1, we do the following
+* v = [ 1 v_2 ]**T
+* If SIDE='L'
+* |-----|
+* | C_1 |
+* C =| C_2 |
+* |-----|
+* C_1\in\mathbb{C}^{1\times n}, C_2\in\mathbb{C}^{m-1\times n}
+* So we compute:
+* C = HC = (I - \tau vv**T)C
+* = C - \tau vv**T C
+* w = C**T v = [ C_1**T C_2**T ] [ 1 v_2 ]**T
+* = C_1**T + C_2**T v ( ZGEMM then ZAXPYC-like )
+* C = C - \tau vv**T C
+* = C - \tau vw**T
+* Giving us C_1 = C_1 - \tau w**T ( ZAXPYC-like )
+* and
+* C_2 = C_2 - \tau v_2w**T ( ZGERC )
+* If SIDE='R'
+*
+* C = [ C_1 C_2 ]
+* C_1\in\mathbb{C}^{m\times 1}, C_2\in\mathbb{C}^{m\times n-1}
+* So we compute:
+* C = CH = C(I - \tau vv**T)
+* = C - \tau Cvv**T
+*
+* w = Cv = [ C_1 C_2 ] [ 1 v_2 ]**T
+* = C_1 + C_2v_2 ( ZGEMM then ZAXPYC-like )
+* C = C - \tau Cvv**T
+* = C - \tau wv**T
+* Giving us C_1 = C_1 - \tau w ( ZAXPYC-like )
+* and
+* C_2 = C_2 - \tau wv_2**T ( ZGERC )
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \ingroup larf
+*
+* =====================================================================
+ SUBROUTINE ZLARF1F( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )
+ IMPLICIT NONE
+*
+* -- LAPACK auxiliary routine --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+*
+* .. Scalar Arguments ..
+ CHARACTER SIDE
+ INTEGER INCV, LDC, M, N
+ COMPLEX*16 TAU
+* ..
+* .. Array Arguments ..
+ COMPLEX*16 C( LDC, * ), V( * ), WORK( * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ COMPLEX*16 ONE, ZERO
+ PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ),
+ $ ZERO = ( 0.0D+0, 0.0D+0 ) )
+* ..
+* .. Local Scalars ..
+ LOGICAL APPLYLEFT
+ INTEGER I, LASTV, LASTC, J
+* ..
+* .. External Subroutines ..
+ EXTERNAL ZAXPY, ZGEMV, ZGERC, ZSCAL
+* .. Intrinsic Functions ..
+ INTRINSIC DCONJG
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAZLR, ILAZLC
+ EXTERNAL LSAME, ILAZLR, ILAZLC
+* ..
+* .. Executable Statements ..
+*
+ APPLYLEFT = LSAME( SIDE, 'L' )
+ LASTV = 1
+ LASTC = 0
+ IF( TAU.NE.ZERO ) THEN
+! Set up variables for scanning V. LASTV begins pointing to the end
+! of V.
+ IF( APPLYLEFT ) THEN
+ LASTV = M
+ ELSE
+ LASTV = N
+ END IF
+ IF( INCV.GT.0 ) THEN
+ I = 1 + (LASTV-1) * INCV
+ ELSE
+ I = 1
+ END IF
+! Look for the last non-zero row in V.
+! Since we are assuming that V(1) = 1, and it is not stored, so we
+! shouldn't access it.
+ DO WHILE( LASTV.GT.1 .AND. V( I ).EQ.ZERO )
+ LASTV = LASTV - 1
+ I = I - INCV
+ END DO
+ IF( APPLYLEFT ) THEN
+! Scan for the last non-zero column in C(1:lastv,:).
+ LASTC = ILAZLC(LASTV, N, C, LDC)
+ ELSE
+! Scan for the last non-zero row in C(:,1:lastv).
+ LASTC = ILAZLR(M, LASTV, C, LDC)
+ END IF
+ END IF
+ IF( LASTC.EQ.0 ) THEN
+ RETURN
+ END IF
+ IF( APPLYLEFT ) THEN
+*
+* Form H * C
+*
+ ! Check if m = 1. This means v = 1, So we just need to compute
+ ! C := HC = (1-\tau)C.
+ IF( LASTV.EQ.1 ) THEN
+ CALL ZSCAL(LASTC, ONE - TAU, C, LDC)
+ ELSE
+*
+* w(1:lastc,1) := C(1:lastv,1:lastc)**H * v(1:lastv,1)
+*
+ ! (I - tvv**H)C = C - tvv**H C
+ ! First compute w**H = v**H c -> w = C**H v
+ ! C = [ C_1 C_2 ]**T, v = [1 v_2]**T
+ ! w = C_1**H + C_2**Hv_2
+ ! w = C_2**Hv_2
+ CALL ZGEMV( 'Conjugate transpose', LASTV - 1,
+ $ LASTC, ONE, C( 1+1, 1 ), LDC, V( 1 + INCV ),
+ $ INCV, ZERO, WORK, 1 )
+*
+* w(1:lastc,1) += v(1,1) * C(1,1:lastc)**H
+*
+ DO I = 1, LASTC
+ WORK( I ) = WORK( I ) + DCONJG( C( 1, I ) )
+ END DO
+*
+* C(1:lastv,1:lastc) := C(...) - tau * v(1:lastv,1) * w(1:lastc,1)**H
+*
+ ! C(1, 1:lastc) := C(...) - tau * v(1,1) * w(1:lastc,1)**H
+ ! = C(...) - tau * Conj(w(1:lastc,1))
+ ! This is essentially a zaxpyc
+ DO I = 1, LASTC
+ C( 1, I ) = C( 1, I ) - TAU * DCONJG( WORK( I ) )
+ END DO
+*
+* C(2:lastv,1:lastc) += - tau * v(2:lastv,1) * w(1:lastc,1)**H
+*
+ CALL ZGERC( LASTV - 1, LASTC, -TAU, V( 1 + INCV ),
+ $ INCV, WORK, 1, C( 1+1, 1 ), LDC )
+ END IF
+ ELSE
+*
+* Form C * H
+*
+ ! Check if n = 1. This means v = 1, so we just need to compute
+ ! C := CH = C(1-\tau).
+ IF( LASTV.EQ.1 ) THEN
+ CALL ZSCAL(LASTC, ONE - TAU, C, 1)
+ ELSE
+*
+* w(1:lastc,1) := C(1:lastc,1:lastv) * v(1:lastv,1)
+*
+ ! w(1:lastc,1) := C(1:lastc,2:lastv) * v(2:lastv,1)
+ CALL ZGEMV( 'No transpose', LASTC, LASTV-1, ONE,
+ $ C(1,1+1), LDC, V(1+INCV), INCV, ZERO, WORK, 1 )
+ ! w(1:lastc,1) += C(1:lastc,1) v(1,1) = C(1:lastc,1)
+ CALL ZAXPY(LASTC, ONE, C, 1, WORK, 1)
+*
+* C(1:lastc,1:lastv) := C(...) - tau * w(1:lastc,1) * v(1:lastv,1)**T
+*
+ ! C(1:lastc,1) := C(...) - tau * w(1:lastc,1) * v(1,1)**T
+ ! = C(...) - tau * w(1:lastc,1)
+ CALL ZAXPY(LASTC, -TAU, WORK, 1, C, 1)
+ ! C(1:lastc,2:lastv) := C(...) - tau * w(1:lastc,1) * v(2:lastv)**T
+ CALL ZGERC( LASTC, LASTV-1, -TAU, WORK, 1, V(1+INCV),
+ $ INCV, C(1,1+1), LDC )
+ END IF
+ END IF
+ RETURN
+*
+* End of ZLARF1F
+*
+ END
diff --git a/lapack-netlib/SRC/zlarf1l.c b/lapack-netlib/SRC/zlarf1l.c
new file mode 100644
index 0000000000..305a77c944
--- /dev/null
+++ b/lapack-netlib/SRC/zlarf1l.c
@@ -0,0 +1,555 @@
+#include
+#include
+#include
+#include
+#include
+#ifdef complex
+#undef complex
+#endif
+#ifdef I
+#undef I
+#endif
+
+#if defined(_WIN64)
+typedef long long BLASLONG;
+typedef unsigned long long BLASULONG;
+#else
+typedef long BLASLONG;
+typedef unsigned long BLASULONG;
+#endif
+
+#ifdef LAPACK_ILP64
+typedef BLASLONG blasint;
+#if defined(_WIN64)
+#define blasabs(x) llabs(x)
+#else
+#define blasabs(x) labs(x)
+#endif
+#else
+typedef int blasint;
+#define blasabs(x) abs(x)
+#endif
+
+typedef blasint integer;
+
+typedef unsigned int uinteger;
+typedef char *address;
+typedef short int shortint;
+typedef float real;
+typedef double doublereal;
+typedef struct { real r, i; } complex;
+typedef struct { doublereal r, i; } doublecomplex;
+#ifdef _MSC_VER
+static inline _Fcomplex Cf(complex *z) {_Fcomplex zz={z->r , z->i}; return zz;}
+static inline _Dcomplex Cd(doublecomplex *z) {_Dcomplex zz={z->r , z->i};return zz;}
+static inline _Fcomplex * _pCf(complex *z) {return (_Fcomplex*)z;}
+static inline _Dcomplex * _pCd(doublecomplex *z) {return (_Dcomplex*)z;}
+#else
+static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;}
+static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;}
+static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;}
+static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;}
+#endif
+#define pCf(z) (*_pCf(z))
+#define pCd(z) (*_pCd(z))
+typedef int logical;
+typedef short int shortlogical;
+typedef char logical1;
+typedef char integer1;
+
+#define TRUE_ (1)
+#define FALSE_ (0)
+
+/* Extern is for use with -E */
+#ifndef Extern
+#define Extern extern
+#endif
+
+/* I/O stuff */
+
+typedef int flag;
+typedef int ftnlen;
+typedef int ftnint;
+
+/*external read, write*/
+typedef struct
+{ flag cierr;
+ ftnint ciunit;
+ flag ciend;
+ char *cifmt;
+ ftnint cirec;
+} cilist;
+
+/*internal read, write*/
+typedef struct
+{ flag icierr;
+ char *iciunit;
+ flag iciend;
+ char *icifmt;
+ ftnint icirlen;
+ ftnint icirnum;
+} icilist;
+
+/*open*/
+typedef struct
+{ flag oerr;
+ ftnint ounit;
+ char *ofnm;
+ ftnlen ofnmlen;
+ char *osta;
+ char *oacc;
+ char *ofm;
+ ftnint orl;
+ char *oblnk;
+} olist;
+
+/*close*/
+typedef struct
+{ flag cerr;
+ ftnint cunit;
+ char *csta;
+} cllist;
+
+/*rewind, backspace, endfile*/
+typedef struct
+{ flag aerr;
+ ftnint aunit;
+} alist;
+
+/* inquire */
+typedef struct
+{ flag inerr;
+ ftnint inunit;
+ char *infile;
+ ftnlen infilen;
+ ftnint *inex; /*parameters in standard's order*/
+ ftnint *inopen;
+ ftnint *innum;
+ ftnint *innamed;
+ char *inname;
+ ftnlen innamlen;
+ char *inacc;
+ ftnlen inacclen;
+ char *inseq;
+ ftnlen inseqlen;
+ char *indir;
+ ftnlen indirlen;
+ char *infmt;
+ ftnlen infmtlen;
+ char *inform;
+ ftnint informlen;
+ char *inunf;
+ ftnlen inunflen;
+ ftnint *inrecl;
+ ftnint *innrec;
+ char *inblank;
+ ftnlen inblanklen;
+} inlist;
+
+#define VOID void
+
+union Multitype { /* for multiple entry points */
+ integer1 g;
+ shortint h;
+ integer i;
+ /* longint j; */
+ real r;
+ doublereal d;
+ complex c;
+ doublecomplex z;
+ };
+
+typedef union Multitype Multitype;
+
+struct Vardesc { /* for Namelist */
+ char *name;
+ char *addr;
+ ftnlen *dims;
+ int type;
+ };
+typedef struct Vardesc Vardesc;
+
+struct Namelist {
+ char *name;
+ Vardesc **vars;
+ int nvars;
+ };
+typedef struct Namelist Namelist;
+
+#define abs(x) ((x) >= 0 ? (x) : -(x))
+#define dabs(x) (fabs(x))
+#define f2cmin(a,b) ((a) <= (b) ? (a) : (b))
+#define f2cmax(a,b) ((a) >= (b) ? (a) : (b))
+#define dmin(a,b) (f2cmin(a,b))
+#define dmax(a,b) (f2cmax(a,b))
+#define bit_test(a,b) ((a) >> (b) & 1)
+#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b)))
+#define bit_set(a,b) ((a) | ((uinteger)1 << (b)))
+
+#define abort_() { sig_die("Fortran abort routine called", 1); }
+#define c_abs(z) (cabsf(Cf(z)))
+#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); }
+#ifdef _MSC_VER
+#define c_div(c, a, b) {Cf(c)._Val[0] = (Cf(a)._Val[0]/Cf(b)._Val[0]); Cf(c)._Val[1]=(Cf(a)._Val[1]/Cf(b)._Val[1]);}
+#define z_div(c, a, b) {Cd(c)._Val[0] = (Cd(a)._Val[0]/Cd(b)._Val[0]); Cd(c)._Val[1]=(Cd(a)._Val[1]/Cd(b)._Val[1]);}
+#else
+#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);}
+#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);}
+#endif
+#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));}
+#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));}
+#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));}
+//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));}
+#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));}
+#define d_abs(x) (fabs(*(x)))
+#define d_acos(x) (acos(*(x)))
+#define d_asin(x) (asin(*(x)))
+#define d_atan(x) (atan(*(x)))
+#define d_atn2(x, y) (atan2(*(x),*(y)))
+#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); }
+#define r_cnjg(R, Z) { pCf(R) = conjf(Cf(Z)); }
+#define d_cos(x) (cos(*(x)))
+#define d_cosh(x) (cosh(*(x)))
+#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 )
+#define d_exp(x) (exp(*(x)))
+#define d_imag(z) (cimag(Cd(z)))
+#define r_imag(z) (cimagf(Cf(z)))
+#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define d_log(x) (log(*(x)))
+#define d_mod(x, y) (fmod(*(x), *(y)))
+#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x)))
+#define d_nint(x) u_nint(*(x))
+#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a)))
+#define d_sign(a,b) u_sign(*(a),*(b))
+#define r_sign(a,b) u_sign(*(a),*(b))
+#define d_sin(x) (sin(*(x)))
+#define d_sinh(x) (sinh(*(x)))
+#define d_sqrt(x) (sqrt(*(x)))
+#define d_tan(x) (tan(*(x)))
+#define d_tanh(x) (tanh(*(x)))
+#define i_abs(x) abs(*(x))
+#define i_dnnt(x) ((integer)u_nint(*(x)))
+#define i_len(s, n) (n)
+#define i_nint(x) ((integer)u_nint(*(x)))
+#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b)))
+#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; }
+#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d))))
+#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
+#define sig_die(s, kill) { exit(1); }
+#define s_stop(s, n) {exit(0);}
+#define z_abs(z) (cabs(Cd(z)))
+#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
+#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
+
+/* procedure parameter types for -A and -C++ */
+
+#define F2C_proc_par_types 1
+#ifdef __cplusplus
+typedef logical (*L_fp)(...);
+#else
+typedef logical (*L_fp)();
+#endif
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {1.,0.};
+static doublecomplex c_b2 = {0.,0.};
+static integer c__1 = 1;
+
+/* > \brief \b ZLARF1L applies an elementary reflector to a general rectangular */
+/* matrix assuming v(lastv) = 1, where lastv is the last non-zero */
+
+/* =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/* http://www.netlib.org/lapack/explore-html/ */
+
+/* > Download ZLARF1L + dependencies */
+/* >
+*/
+/* > [TGZ] */
+/* >
+*/
+/* > [ZIP] */
+/* >
+*/
+/* > [TXT] */
+
+/* Definition: */
+/* =========== */
+
+/* SUBROUTINE ZLARF1L( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) */
+
+/* CHARACTER SIDE */
+/* INTEGER INCV, LDC, M, N */
+/* COMPLEX*16 TAU */
+/* COMPLEX*16 C( LDC, * ), V( * ), WORK( * ) */
+
+
+/* > \par Purpose: */
+/* ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > ZLARF1L applies a complex elementary reflector H to a complex m by n matrix */
+/* > C, from either the left or the right. H is represented in the form */
+/* > */
+/* > H = I - tau * v * v**H */
+/* > */
+/* > where tau is a real scalar and v is a real vector assuming v(lastv) = 1, */
+/* > where lastv is the last non-zero element. */
+/* > */
+/* > If tau = 0, then H is taken to be the unit matrix. */
+/* > */
+/* > To apply H**H (the conjugate transpose of H), supply conjg(tau) instead */
+/* > tau. */
+/* > \endverbatim */
+
+/* Arguments: */
+/* ========== */
+
+/* > \param[in] SIDE */
+/* > \verbatim */
+/* > SIDE is CHARACTER*1 */
+/* > = 'L': form H * C */
+/* > = 'R': form C * H */
+/* > \endverbatim */
+/* > */
+/* > \param[in] M */
+/* > \verbatim */
+/* > M is INTEGER */
+/* > The number of rows of the matrix C. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] N */
+/* > \verbatim */
+/* > N is INTEGER */
+/* > The number of columns of the matrix C. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] V */
+/* > \verbatim */
+/* > V is COMPLEX*16 array, dimension */
+/* > (1 + (M-1)*abs(INCV)) if SIDE = 'L' */
+/* > or (1 + (N-1)*abs(INCV)) if SIDE = 'R' */
+/* > The vector v in the representation of H. V is not used if */
+/* > TAU = 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] INCV */
+/* > \verbatim */
+/* > INCV is INTEGER */
+/* > The increment between elements of v. INCV > 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] TAU */
+/* > \verbatim */
+/* > TAU is COMPLEX*16 */
+/* > The value tau in the representation of H. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] C */
+/* > \verbatim */
+/* > C is COMPLEX*16 array, dimension (LDC,N) */
+/* > On entry, the m by n matrix C. */
+/* > On exit, C is overwritten by the matrix H * C if SIDE = 'L', */
+/* > or C * H if SIDE = 'R'. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDC */
+/* > \verbatim */
+/* > LDC is INTEGER */
+/* > The leading dimension of the array C. LDC >= f2cmax(1,M). */
+/* > \endverbatim */
+/* > */
+/* > \param[out] WORK */
+/* > \verbatim */
+/* > WORK is COMPLEX*16 array, dimension */
+/* > (N) if SIDE = 'L' */
+/* > or (M) if SIDE = 'R' */
+/* > \endverbatim */
+
+/* Authors: */
+/* ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \ingroup larf1f */
+
+/* ===================================================================== */
+/* Subroutine */ int zlarf1l_(char *side, integer *m, integer *n,
+ doublecomplex *v, integer *incv, doublecomplex *tau, doublecomplex *
+ c__, integer *ldc, doublecomplex *work)
+{
+ /* System generated locals */
+ integer c_dim1, c_offset, i__1, i__2, i__3;
+ doublecomplex z__1, z__2, z__3;
+
+ /* Local variables */
+ integer i__, j;
+ logical applyleft;
+ extern logical lsame_(char *, char *);
+ integer lastc;
+ extern /* Subroutine */ int zgerc_(integer *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), zscal_(integer *, doublecomplex *,
+ doublecomplex *, integer *), zgemv_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *);
+ integer lastv;
+ extern /* Subroutine */ int zaxpy_(integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ extern integer ilazlc_(integer *, integer *, doublecomplex *, integer *),
+ ilazlr_(integer *, integer *, doublecomplex *, integer *);
+ integer firstv;
+
+
+/* -- LAPACK auxiliary routine -- */
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+
+
+/* ===================================================================== */
+
+
+ /* Parameter adjustments */
+ --v;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --work;
+
+ /* Function Body */
+ applyleft = lsame_(side, "L");
+ firstv = 1;
+ lastc = 0;
+ if (tau->r != 0. || tau->i != 0.) {
+/* Set up variables for scanning V. LASTV begins pointing to the end */
+/* of V up to V(1). */
+ if (applyleft) {
+ lastv = *m;
+ } else {
+ lastv = *n;
+ }
+ i__ = 1;
+/* Look for the last non-zero row in V. */
+ for(;;) { /* while(complicated condition) */
+ i__1 = i__;
+ if (!(lastv > firstv && (v[i__1].r == 0. && v[i__1].i == 0.)))
+ break;
+ ++firstv;
+ i__ += *incv;
+ }
+ if (applyleft) {
+/* Scan for the last non-zero column in C(1:lastv,:). */
+ lastc = ilazlc_(&lastv, n, &c__[c_offset], ldc);
+ } else {
+/* Scan for the last non-zero row in C(:,1:lastv). */
+ lastc = ilazlr_(m, &lastv, &c__[c_offset], ldc);
+ }
+ }
+ if (lastc == 0) {
+ return 0;
+ }
+ if (applyleft) {
+
+/* Form H * C */
+
+ if (lastv == firstv) {
+
+/* C(lastv,1:lastc) := ( 1 - tau ) * C(lastv,1:lastc) */
+
+ z__1.r = 1. - tau->r, z__1.i = 0. - tau->i;
+ zscal_(&lastc, &z__1, &c__[lastv + c_dim1], ldc);
+ } else {
+
+/* w(1:lastc,1) := C(firstv:lastv-1,1:lastc)**T * v(firstv:lastv-1,1) */
+
+ i__1 = lastv - firstv;
+ zgemv_("Conjugate transpose", &i__1, &lastc, &c_b1, &c__[firstv +
+ c_dim1], ldc, &v[i__], incv, &c_b2, &work[1], &c__1);
+
+/* w(1:lastc,1) += C(lastv,1:lastc)**H * v(lastv,1) */
+
+ i__1 = lastc;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ i__3 = j;
+ d_cnjg(&z__2, &c__[lastv + j * c_dim1]);
+ z__1.r = work[i__3].r + z__2.r, z__1.i = work[i__3].i +
+ z__2.i;
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+ }
+
+/* C(lastv,1:lastc) += - tau * v(lastv,1) * w(1:lastc,1)**H */
+
+ i__1 = lastc;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = lastv + j * c_dim1;
+ i__3 = lastv + j * c_dim1;
+ d_cnjg(&z__3, &work[j]);
+ z__2.r = tau->r * z__3.r - tau->i * z__3.i, z__2.i = tau->r *
+ z__3.i + tau->i * z__3.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+ }
+
+/* C(firstv:lastv-1,1:lastc) += - tau * v(firstv:lastv-1,1) * w(1:lastc,1)**H */
+
+ i__1 = lastv - firstv;
+ z__1.r = -tau->r, z__1.i = -tau->i;
+ zgerc_(&i__1, &lastc, &z__1, &v[i__], incv, &work[1], &c__1, &c__[
+ firstv + c_dim1], ldc);
+ }
+ } else {
+
+/* Form C * H */
+
+ if (lastv == firstv) {
+
+/* C(1:lastc,lastv) := ( 1 - tau ) * C(1:lastc,lastv) */
+
+ z__1.r = 1. - tau->r, z__1.i = 0. - tau->i;
+ zscal_(&lastc, &z__1, &c__[lastv * c_dim1 + 1], &c__1);
+ } else {
+
+/* w(1:lastc,1) := C(1:lastc,firstv:lastv-1) * v(firstv:lastv-1,1) */
+
+ i__1 = lastv - firstv;
+ zgemv_("No transpose", &lastc, &i__1, &c_b1, &c__[firstv * c_dim1
+ + 1], ldc, &v[i__], incv, &c_b2, &work[1], &c__1);
+
+/* w(1:lastc,1) += C(1:lastc,lastv) * v(lastv,1) */
+
+ zaxpy_(&lastc, &c_b1, &c__[lastv * c_dim1 + 1], &c__1, &work[1], &
+ c__1);
+
+/* C(1:lastc,lastv) += - tau * v(lastv,1) * w(1:lastc,1) */
+
+ z__1.r = -tau->r, z__1.i = -tau->i;
+ zaxpy_(&lastc, &z__1, &work[1], &c__1, &c__[lastv * c_dim1 + 1], &
+ c__1);
+
+/* C(1:lastc,firstv:lastv-1) += - tau * w(1:lastc,1) * v(firstv:lastv-1)**H */
+
+ i__1 = lastv - firstv;
+ z__1.r = -tau->r, z__1.i = -tau->i;
+ zgerc_(&lastc, &i__1, &z__1, &work[1], &c__1, &v[i__], incv, &c__[
+ firstv * c_dim1 + 1], ldc);
+ }
+ }
+ return 0;
+
+/* End of ZLARF1L */
+
+} /* zlarf1l_ */
+
diff --git a/lapack-netlib/SRC/zlarf1l.f b/lapack-netlib/SRC/zlarf1l.f
new file mode 100644
index 0000000000..2a3bd1d373
--- /dev/null
+++ b/lapack-netlib/SRC/zlarf1l.f
@@ -0,0 +1,267 @@
+*> \brief \b ZLARF1L applies an elementary reflector to a general rectangular
+* matrix assuming v(lastv) = 1, where lastv is the last non-zero
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> Download ZLARF1L + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZLARF1L( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )
+*
+* .. Scalar Arguments ..
+* CHARACTER SIDE
+* INTEGER INCV, LDC, M, N
+* COMPLEX*16 TAU
+* ..
+* .. Array Arguments ..
+* COMPLEX*16 C( LDC, * ), V( * ), WORK( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> ZLARF1L applies a complex elementary reflector H to a complex m by n matrix
+*> C, from either the left or the right. H is represented in the form
+*>
+*> H = I - tau * v * v**H
+*>
+*> where tau is a real scalar and v is a real vector assuming v(lastv) = 1,
+*> where lastv is the last non-zero element.
+*>
+*> If tau = 0, then H is taken to be the unit matrix.
+*>
+*> To apply H**H (the conjugate transpose of H), supply conjg(tau) instead
+*> tau.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] SIDE
+*> \verbatim
+*> SIDE is CHARACTER*1
+*> = 'L': form H * C
+*> = 'R': form C * H
+*> \endverbatim
+*>
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows of the matrix C.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of columns of the matrix C.
+*> \endverbatim
+*>
+*> \param[in] V
+*> \verbatim
+*> V is COMPLEX*16 array, dimension
+*> (1 + (M-1)*abs(INCV)) if SIDE = 'L'
+*> or (1 + (N-1)*abs(INCV)) if SIDE = 'R'
+*> The vector v in the representation of H. V is not used if
+*> TAU = 0.
+*> \endverbatim
+*>
+*> \param[in] INCV
+*> \verbatim
+*> INCV is INTEGER
+*> The increment between elements of v. INCV > 0.
+*> \endverbatim
+*>
+*> \param[in] TAU
+*> \verbatim
+*> TAU is COMPLEX*16
+*> The value tau in the representation of H.
+*> \endverbatim
+*>
+*> \param[in,out] C
+*> \verbatim
+*> C is COMPLEX*16 array, dimension (LDC,N)
+*> On entry, the m by n matrix C.
+*> On exit, C is overwritten by the matrix H * C if SIDE = 'L',
+*> or C * H if SIDE = 'R'.
+*> \endverbatim
+*>
+*> \param[in] LDC
+*> \verbatim
+*> LDC is INTEGER
+*> The leading dimension of the array C. LDC >= max(1,M).
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is COMPLEX*16 array, dimension
+*> (N) if SIDE = 'L'
+*> or (M) if SIDE = 'R'
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \ingroup larf1f
+*
+* =====================================================================
+ SUBROUTINE ZLARF1L( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )
+ IMPLICIT NONE
+*
+* -- LAPACK auxiliary routine --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+*
+* .. Scalar Arguments ..
+ CHARACTER SIDE
+ INTEGER INCV, LDC, M, N
+ COMPLEX*16 TAU
+* ..
+* .. Array Arguments ..
+ COMPLEX*16 C( LDC, * ), V( * ), WORK( * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ COMPLEX*16 ONE, ZERO
+ PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ),
+ $ ZERO = ( 0.0D+0, 0.0D+0 ) )
+* ..
+* .. Local Scalars ..
+ LOGICAL APPLYLEFT
+ INTEGER I, J, LASTV, LASTC, FIRSTV
+* ..
+* .. External Subroutines ..
+ EXTERNAL ZAXPY, ZGEMV, ZGERC, ZSCAL
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC DCONJG
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAZLR, ILAZLC
+ EXTERNAL LSAME, ILAZLR, ILAZLC
+* ..
+* .. Executable Statements ..
+*
+ APPLYLEFT = LSAME( SIDE, 'L' )
+ FIRSTV = 1
+ LASTC = 0
+ IF( TAU.NE.ZERO ) THEN
+! Set up variables for scanning V. LASTV begins pointing to the end
+! of V up to V(1).
+ IF( APPLYLEFT ) THEN
+ LASTV = M
+ ELSE
+ LASTV = N
+ END IF
+ I = 1
+! Look for the last non-zero row in V.
+ DO WHILE( LASTV.GT.FIRSTV .AND. V( I ).EQ.ZERO )
+ FIRSTV = FIRSTV + 1
+ I = I + INCV
+ END DO
+ IF( APPLYLEFT ) THEN
+! Scan for the last non-zero column in C(1:lastv,:).
+ LASTC = ILAZLC(LASTV, N, C, LDC)
+ ELSE
+! Scan for the last non-zero row in C(:,1:lastv).
+ LASTC = ILAZLR(M, LASTV, C, LDC)
+ END IF
+ END IF
+ IF( LASTC.EQ.0 ) THEN
+ RETURN
+ END IF
+ IF( APPLYLEFT ) THEN
+*
+* Form H * C
+*
+ IF( LASTV.EQ.FIRSTV ) THEN
+*
+* C(lastv,1:lastc) := ( 1 - tau ) * C(lastv,1:lastc)
+*
+ CALL ZSCAL( LASTC, ONE - TAU, C( LASTV, 1 ), LDC )
+ ELSE
+*
+* w(1:lastc,1) := C(firstv:lastv-1,1:lastc)**T * v(firstv:lastv-1,1)
+*
+ CALL ZGEMV( 'Conjugate transpose', LASTV - FIRSTV, LASTC,
+ $ ONE, C( FIRSTV, 1 ), LDC, V( I ), INCV, ZERO,
+ $ WORK, 1 )
+*
+* w(1:lastc,1) += C(lastv,1:lastc)**H * v(lastv,1)
+*
+ DO J = 1, LASTC
+ WORK( J ) = WORK( J ) + CONJG( C( LASTV, J ) )
+ END DO
+*
+* C(lastv,1:lastc) += - tau * v(lastv,1) * w(1:lastc,1)**H
+*
+ DO J = 1, LASTC
+ C( LASTV, J ) = C( LASTV, J )
+ $ - TAU * CONJG( WORK( J ) )
+ END DO
+*
+* C(firstv:lastv-1,1:lastc) += - tau * v(firstv:lastv-1,1) * w(1:lastc,1)**H
+*
+ CALL ZGERC( LASTV - FIRSTV, LASTC, -TAU, V( I ), INCV,
+ $ WORK, 1, C( FIRSTV, 1 ), LDC)
+ END IF
+ ELSE
+*
+* Form C * H
+*
+ IF( LASTV.EQ.FIRSTV ) THEN
+*
+* C(1:lastc,lastv) := ( 1 - tau ) * C(1:lastc,lastv)
+*
+ CALL ZSCAL( LASTC, ONE - TAU, C( 1, LASTV ), 1 )
+ ELSE
+*
+* w(1:lastc,1) := C(1:lastc,firstv:lastv-1) * v(firstv:lastv-1,1)
+*
+ CALL ZGEMV( 'No transpose', LASTC, LASTV - FIRSTV, ONE,
+ $ C( 1, FIRSTV ), LDC, V( I ), INCV, ZERO,
+ $ WORK, 1 )
+*
+* w(1:lastc,1) += C(1:lastc,lastv) * v(lastv,1)
+*
+ CALL ZAXPY( LASTC, ONE, C( 1, LASTV ), 1, WORK, 1 )
+*
+* C(1:lastc,lastv) += - tau * v(lastv,1) * w(1:lastc,1)
+*
+ CALL ZAXPY( LASTC, -TAU, WORK, 1, C( 1, LASTV ), 1 )
+*
+* C(1:lastc,firstv:lastv-1) += - tau * w(1:lastc,1) * v(firstv:lastv-1)**H
+*
+ CALL ZGERC( LASTC, LASTV - FIRSTV, -TAU, WORK, 1, V( I ),
+ $ INCV, C( 1, FIRSTV ), LDC )
+ END IF
+ END IF
+ RETURN
+*
+* End of ZLARF1L
+*
+ END
diff --git a/lapack-netlib/SRC/zunbdb.f b/lapack-netlib/SRC/zunbdb.f
index 281ec6e45f..e0c8beadec 100644
--- a/lapack-netlib/SRC/zunbdb.f
+++ b/lapack-netlib/SRC/zunbdb.f
@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
-*> \htmlonly
*> Download ZUNBDB + dependencies
*>
*> [TGZ]
@@ -13,7 +12,6 @@
*> [ZIP]
*>
*> [TXT]
-*> \endhtmlonly
*
* Definition:
* ===========
@@ -255,7 +253,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \ingroup complex16OTHERcomputational
+*> \ingroup unbdb
*
*> \par Further Details:
* =====================
@@ -281,9 +279,11 @@
*> Algorithms, 50(1):33-65, 2009.
*>
* =====================================================================
- SUBROUTINE ZUNBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12,
+ SUBROUTINE ZUNBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12,
+ $ LDX12,
$ X21, LDX21, X22, LDX22, THETA, PHI, TAUP1,
$ TAUP2, TAUQ1, TAUQ2, WORK, LWORK, INFO )
+ IMPLICIT NONE
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
@@ -315,7 +315,8 @@ SUBROUTINE ZUNBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12,
DOUBLE PRECISION Z1, Z2, Z3, Z4
* ..
* .. External Subroutines ..
- EXTERNAL ZAXPY, ZLARF, ZLARFGP, ZSCAL, XERBLA
+ EXTERNAL ZAXPY, ZLARF1F, ZLARFGP, ZSCAL,
+ $ XERBLA
EXTERNAL ZLACGV
*
* ..
@@ -406,9 +407,11 @@ SUBROUTINE ZUNBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12,
$ 0.0D0 ), X12(I,I-1), 1, X11(I,I), 1 )
END IF
IF( I .EQ. 1 ) THEN
- CALL ZSCAL( M-P-I+1, DCMPLX( Z2, 0.0D0 ), X21(I,I), 1 )
+ CALL ZSCAL( M-P-I+1, DCMPLX( Z2, 0.0D0 ), X21(I,I),
+ $ 1 )
ELSE
- CALL ZSCAL( M-P-I+1, DCMPLX( Z2*COS(PHI(I-1)), 0.0D0 ),
+ CALL ZSCAL( M-P-I+1, DCMPLX( Z2*COS(PHI(I-1)),
+ $ 0.0D0 ),
$ X21(I,I), 1 )
CALL ZAXPY( M-P-I+1, DCMPLX( -Z2*Z3*Z4*SIN(PHI(I-1)),
$ 0.0D0 ), X22(I,I-1), 1, X21(I,I), 1 )
@@ -418,11 +421,11 @@ SUBROUTINE ZUNBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12,
$ DZNRM2( P-I+1, X11(I,I), 1 ) )
*
IF( P .GT. I ) THEN
- CALL ZLARFGP( P-I+1, X11(I,I), X11(I+1,I), 1, TAUP1(I) )
+ CALL ZLARFGP( P-I+1, X11(I,I), X11(I+1,I), 1,
+ $ TAUP1(I) )
ELSE IF ( P .EQ. I ) THEN
CALL ZLARFGP( P-I+1, X11(I,I), X11(I,I), 1, TAUP1(I) )
END IF
- X11(I,I) = ONE
IF ( M-P .GT. I ) THEN
CALL ZLARFGP( M-P-I+1, X21(I,I), X21(I+1,I), 1,
$ TAUP2(I) )
@@ -430,30 +433,34 @@ SUBROUTINE ZUNBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12,
CALL ZLARFGP( M-P-I+1, X21(I,I), X21(I,I), 1,
$ TAUP2(I) )
END IF
- X21(I,I) = ONE
*
IF ( Q .GT. I ) THEN
- CALL ZLARF( 'L', P-I+1, Q-I, X11(I,I), 1,
- $ DCONJG(TAUP1(I)), X11(I,I+1), LDX11, WORK )
- CALL ZLARF( 'L', M-P-I+1, Q-I, X21(I,I), 1,
- $ DCONJG(TAUP2(I)), X21(I,I+1), LDX21, WORK )
+ CALL ZLARF1F( 'L', P-I+1, Q-I, X11(I,I), 1,
+ $ CONJG(TAUP1(I)), X11(I,I+1), LDX11,
+ $ WORK )
+ CALL ZLARF1F( 'L', M-P-I+1, Q-I, X21(I,I), 1,
+ $ CONJG(TAUP2(I)), X21(I,I+1), LDX21,
+ $ WORK )
END IF
IF ( M-Q+1 .GT. I ) THEN
- CALL ZLARF( 'L', P-I+1, M-Q-I+1, X11(I,I), 1,
- $ DCONJG(TAUP1(I)), X12(I,I), LDX12, WORK )
- CALL ZLARF( 'L', M-P-I+1, M-Q-I+1, X21(I,I), 1,
- $ DCONJG(TAUP2(I)), X22(I,I), LDX22, WORK )
+ CALL ZLARF1F( 'L', P-I+1, M-Q-I+1, X11(I,I), 1,
+ $ CONJG(TAUP1(I)), X12(I,I), LDX12, WORK )
+ CALL ZLARF1F( 'L', M-P-I+1, M-Q-I+1, X21(I,I), 1,
+ $ CONJG(TAUP2(I)), X22(I,I), LDX22, WORK )
END IF
*
IF( I .LT. Q ) THEN
- CALL ZSCAL( Q-I, DCMPLX( -Z1*Z3*SIN(THETA(I)), 0.0D0 ),
+ CALL ZSCAL( Q-I, DCMPLX( -Z1*Z3*SIN(THETA(I)),
+ $ 0.0D0 ),
$ X11(I,I+1), LDX11 )
CALL ZAXPY( Q-I, DCMPLX( Z2*Z3*COS(THETA(I)), 0.0D0 ),
$ X21(I,I+1), LDX21, X11(I,I+1), LDX11 )
END IF
- CALL ZSCAL( M-Q-I+1, DCMPLX( -Z1*Z4*SIN(THETA(I)), 0.0D0 ),
+ CALL ZSCAL( M-Q-I+1, DCMPLX( -Z1*Z4*SIN(THETA(I)),
+ $ 0.0D0 ),
$ X12(I,I), LDX12 )
- CALL ZAXPY( M-Q-I+1, DCMPLX( Z2*Z4*COS(THETA(I)), 0.0D0 ),
+ CALL ZAXPY( M-Q-I+1, DCMPLX( Z2*Z4*COS(THETA(I)),
+ $ 0.0D0 ),
$ X22(I,I), LDX22, X12(I,I), LDX12 )
*
IF( I .LT. Q )
@@ -469,7 +476,6 @@ SUBROUTINE ZUNBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12,
CALL ZLARFGP( Q-I, X11(I,I+1), X11(I,I+2), LDX11,
$ TAUQ1(I) )
END IF
- X11(I,I+1) = ONE
END IF
IF ( M-Q+1 .GT. I ) THEN
CALL ZLACGV( M-Q-I+1, X12(I,I), LDX12 )
@@ -481,21 +487,23 @@ SUBROUTINE ZUNBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12,
$ TAUQ2(I) )
END IF
END IF
- X12(I,I) = ONE
*
IF( I .LT. Q ) THEN
- CALL ZLARF( 'R', P-I, Q-I, X11(I,I+1), LDX11, TAUQ1(I),
- $ X11(I+1,I+1), LDX11, WORK )
- CALL ZLARF( 'R', M-P-I, Q-I, X11(I,I+1), LDX11, TAUQ1(I),
- $ X21(I+1,I+1), LDX21, WORK )
+ CALL ZLARF1F( 'R', P-I, Q-I, X11(I,I+1), LDX11,
+ $ TAUQ1(I),
+ $ X11(I+1,I+1), LDX11, WORK )
+ CALL ZLARF1F( 'R', M-P-I, Q-I, X11(I,I+1), LDX11,
+ $ TAUQ1(I),
+ $ X21(I+1,I+1), LDX21, WORK )
END IF
IF ( P .GT. I ) THEN
- CALL ZLARF( 'R', P-I, M-Q-I+1, X12(I,I), LDX12, TAUQ2(I),
- $ X12(I+1,I), LDX12, WORK )
+ CALL ZLARF1F( 'R', P-I, M-Q-I+1, X12(I,I), LDX12,
+ $ TAUQ2(I),
+ $ X12(I+1,I), LDX12, WORK )
END IF
IF ( M-P .GT. I ) THEN
- CALL ZLARF( 'R', M-P-I, M-Q-I+1, X12(I,I), LDX12,
- $ TAUQ2(I), X22(I+1,I), LDX22, WORK )
+ CALL ZLARF1F( 'R', M-P-I, M-Q-I+1, X12(I,I), LDX12,
+ $ TAUQ2(I), X22(I+1,I), LDX22, WORK )
END IF
*
IF( I .LT. Q )
@@ -518,15 +526,15 @@ SUBROUTINE ZUNBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12,
CALL ZLARFGP( M-Q-I+1, X12(I,I), X12(I,I+1), LDX12,
$ TAUQ2(I) )
END IF
- X12(I,I) = ONE
*
IF ( P .GT. I ) THEN
- CALL ZLARF( 'R', P-I, M-Q-I+1, X12(I,I), LDX12, TAUQ2(I),
- $ X12(I+1,I), LDX12, WORK )
+ CALL ZLARF1F( 'R', P-I, M-Q-I+1, X12(I,I), LDX12,
+ $ TAUQ2(I),
+ $ X12(I+1,I), LDX12, WORK )
END IF
IF( M-P-Q .GE. 1 )
- $ CALL ZLARF( 'R', M-P-Q, M-Q-I+1, X12(I,I), LDX12,
- $ TAUQ2(I), X22(Q+1,I), LDX22, WORK )
+ $ CALL ZLARF1F( 'R', M-P-Q, M-Q-I+1, X12(I,I), LDX12,
+ $ TAUQ2(I), X22(Q+1,I), LDX22, WORK )
*
CALL ZLACGV( M-Q-I+1, X12(I,I), LDX12 )
*
@@ -541,9 +549,9 @@ SUBROUTINE ZUNBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12,
CALL ZLACGV( M-P-Q-I+1, X22(Q+I,P+I), LDX22 )
CALL ZLARFGP( M-P-Q-I+1, X22(Q+I,P+I), X22(Q+I,P+I+1),
$ LDX22, TAUQ2(P+I) )
- X22(Q+I,P+I) = ONE
- CALL ZLARF( 'R', M-P-Q-I, M-P-Q-I+1, X22(Q+I,P+I), LDX22,
- $ TAUQ2(P+I), X22(Q+I+1,P+I), LDX22, WORK )
+ CALL ZLARF1F( 'R', M-P-Q-I, M-P-Q-I+1, X22(Q+I,P+I),
+ $ LDX22, TAUQ2(P+I), X22(Q+I+1,P+I), LDX22,
+ $ WORK )
*
CALL ZLACGV( M-P-Q-I+1, X22(Q+I,P+I), LDX22 )
*
@@ -568,7 +576,8 @@ SUBROUTINE ZUNBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12,
CALL ZSCAL( M-P-I+1, DCMPLX( Z2, 0.0D0 ), X21(I,I),
$ LDX21 )
ELSE
- CALL ZSCAL( M-P-I+1, DCMPLX( Z2*COS(PHI(I-1)), 0.0D0 ),
+ CALL ZSCAL( M-P-I+1, DCMPLX( Z2*COS(PHI(I-1)),
+ $ 0.0D0 ),
$ X21(I,I), LDX21 )
CALL ZAXPY( M-P-I+1, DCMPLX( -Z2*Z3*Z4*SIN(PHI(I-1)),
$ 0.0D0 ), X22(I-1,I), LDX22, X21(I,I), LDX21 )
@@ -580,8 +589,8 @@ SUBROUTINE ZUNBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12,
CALL ZLACGV( P-I+1, X11(I,I), LDX11 )
CALL ZLACGV( M-P-I+1, X21(I,I), LDX21 )
*
- CALL ZLARFGP( P-I+1, X11(I,I), X11(I,I+1), LDX11, TAUP1(I) )
- X11(I,I) = ONE
+ CALL ZLARFGP( P-I+1, X11(I,I), X11(I,I+1), LDX11,
+ $ TAUP1(I) )
IF ( I .EQ. M-P ) THEN
CALL ZLARFGP( M-P-I+1, X21(I,I), X21(I,I), LDX21,
$ TAUP2(I) )
@@ -589,29 +598,32 @@ SUBROUTINE ZUNBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12,
CALL ZLARFGP( M-P-I+1, X21(I,I), X21(I,I+1), LDX21,
$ TAUP2(I) )
END IF
- X21(I,I) = ONE
*
- CALL ZLARF( 'R', Q-I, P-I+1, X11(I,I), LDX11, TAUP1(I),
- $ X11(I+1,I), LDX11, WORK )
- CALL ZLARF( 'R', M-Q-I+1, P-I+1, X11(I,I), LDX11, TAUP1(I),
- $ X12(I,I), LDX12, WORK )
- CALL ZLARF( 'R', Q-I, M-P-I+1, X21(I,I), LDX21, TAUP2(I),
- $ X21(I+1,I), LDX21, WORK )
- CALL ZLARF( 'R', M-Q-I+1, M-P-I+1, X21(I,I), LDX21,
- $ TAUP2(I), X22(I,I), LDX22, WORK )
+ CALL ZLARF1F( 'R', Q-I, P-I+1, X11(I,I), LDX11, TAUP1(I),
+ $ X11(I+1,I), LDX11, WORK )
+ CALL ZLARF1F( 'R', M-Q-I+1, P-I+1, X11(I,I), LDX11,
+ $ TAUP1(I),
+ $ X12(I,I), LDX12, WORK )
+ CALL ZLARF1F( 'R', Q-I, M-P-I+1, X21(I,I), LDX21,
+ $ TAUP2(I), X21(I+1,I), LDX21, WORK )
+ CALL ZLARF1F( 'R', M-Q-I+1, M-P-I+1, X21(I,I), LDX21,
+ $ TAUP2(I), X22(I,I), LDX22, WORK )
*
CALL ZLACGV( P-I+1, X11(I,I), LDX11 )
CALL ZLACGV( M-P-I+1, X21(I,I), LDX21 )
*
IF( I .LT. Q ) THEN
- CALL ZSCAL( Q-I, DCMPLX( -Z1*Z3*SIN(THETA(I)), 0.0D0 ),
+ CALL ZSCAL( Q-I, DCMPLX( -Z1*Z3*SIN(THETA(I)),
+ $ 0.0D0 ),
$ X11(I+1,I), 1 )
CALL ZAXPY( Q-I, DCMPLX( Z2*Z3*COS(THETA(I)), 0.0D0 ),
$ X21(I+1,I), 1, X11(I+1,I), 1 )
END IF
- CALL ZSCAL( M-Q-I+1, DCMPLX( -Z1*Z4*SIN(THETA(I)), 0.0D0 ),
+ CALL ZSCAL( M-Q-I+1, DCMPLX( -Z1*Z4*SIN(THETA(I)),
+ $ 0.0D0 ),
$ X12(I,I), 1 )
- CALL ZAXPY( M-Q-I+1, DCMPLX( Z2*Z4*COS(THETA(I)), 0.0D0 ),
+ CALL ZAXPY( M-Q-I+1, DCMPLX( Z2*Z4*COS(THETA(I)),
+ $ 0.0D0 ),
$ X22(I,I), 1, X12(I,I), 1 )
*
IF( I .LT. Q )
@@ -619,23 +631,28 @@ SUBROUTINE ZUNBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12,
$ DZNRM2( M-Q-I+1, X12(I,I), 1 ) )
*
IF( I .LT. Q ) THEN
- CALL ZLARFGP( Q-I, X11(I+1,I), X11(I+2,I), 1, TAUQ1(I) )
- X11(I+1,I) = ONE
+ CALL ZLARFGP( Q-I, X11(I+1,I), X11(I+2,I), 1,
+ $ TAUQ1(I) )
END IF
- CALL ZLARFGP( M-Q-I+1, X12(I,I), X12(I+1,I), 1, TAUQ2(I) )
- X12(I,I) = ONE
+ CALL ZLARFGP( M-Q-I+1, X12(I,I), X12(I+1,I), 1,
+ $ TAUQ2(I) )
*
IF( I .LT. Q ) THEN
- CALL ZLARF( 'L', Q-I, P-I, X11(I+1,I), 1,
- $ DCONJG(TAUQ1(I)), X11(I+1,I+1), LDX11, WORK )
- CALL ZLARF( 'L', Q-I, M-P-I, X11(I+1,I), 1,
- $ DCONJG(TAUQ1(I)), X21(I+1,I+1), LDX21, WORK )
+ CALL ZLARF1F( 'L', Q-I, P-I, X11(I+1,I), 1,
+ $ CONJG(TAUQ1(I)), X11(I+1,I+1), LDX11,
+ $ WORK )
+ CALL ZLARF1F( 'L', Q-I, M-P-I, X11(I+1,I), 1,
+ $ CONJG(TAUQ1(I)), X21(I+1,I+1), LDX21,
+ $ WORK )
END IF
- CALL ZLARF( 'L', M-Q-I+1, P-I, X12(I,I), 1,
- $ DCONJG(TAUQ2(I)), X12(I,I+1), LDX12, WORK )
+ CALL ZLARF1F( 'L', M-Q-I+1, P-I, X12(I,I), 1,
+ $ CONJG(TAUQ2(I)),
+ $ X12(I,I+1), LDX12, WORK )
+
IF ( M-P .GT. I ) THEN
- CALL ZLARF( 'L', M-Q-I+1, M-P-I, X12(I,I), 1,
- $ DCONJG(TAUQ2(I)), X22(I,I+1), LDX22, WORK )
+ CALL ZLARF1F( 'L', M-Q-I+1, M-P-I, X12(I,I), 1,
+ $ CONJG(TAUQ2(I)), X22(I,I+1), LDX22,
+ $ WORK )
END IF
*
END DO
@@ -644,17 +661,20 @@ SUBROUTINE ZUNBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12,
*
DO I = Q + 1, P
*
- CALL ZSCAL( M-Q-I+1, DCMPLX( -Z1*Z4, 0.0D0 ), X12(I,I), 1 )
- CALL ZLARFGP( M-Q-I+1, X12(I,I), X12(I+1,I), 1, TAUQ2(I) )
- X12(I,I) = ONE
+ CALL ZSCAL( M-Q-I+1, DCMPLX( -Z1*Z4, 0.0D0 ), X12(I,I),
+ $ 1 )
+ CALL ZLARFGP( M-Q-I+1, X12(I,I), X12(I+1,I), 1,
+ $ TAUQ2(I) )
*
IF ( P .GT. I ) THEN
- CALL ZLARF( 'L', M-Q-I+1, P-I, X12(I,I), 1,
- $ DCONJG(TAUQ2(I)), X12(I,I+1), LDX12, WORK )
+ CALL ZLARF1F( 'L', M-Q-I+1, P-I, X12(I,I), 1,
+ $ CONJG(TAUQ2(I)), X12(I,I+1), LDX12,
+ $ WORK )
END IF
IF( M-P-Q .GE. 1 )
- $ CALL ZLARF( 'L', M-Q-I+1, M-P-Q, X12(I,I), 1,
- $ DCONJG(TAUQ2(I)), X22(I,Q+1), LDX22, WORK )
+ $ CALL ZLARF1F( 'L', M-Q-I+1, M-P-Q, X12(I,I), 1,
+ $ CONJG(TAUQ2(I)), X22(I,Q+1), LDX22,
+ $ WORK )
*
END DO
*
@@ -666,12 +686,10 @@ SUBROUTINE ZUNBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12,
$ X22(P+I,Q+I), 1 )
CALL ZLARFGP( M-P-Q-I+1, X22(P+I,Q+I), X22(P+I+1,Q+I), 1,
$ TAUQ2(P+I) )
- X22(P+I,Q+I) = ONE
-*
IF ( M-P-Q .NE. I ) THEN
- CALL ZLARF( 'L', M-P-Q-I+1, M-P-Q-I, X22(P+I,Q+I), 1,
- $ DCONJG(TAUQ2(P+I)), X22(P+I,Q+I+1), LDX22,
- $ WORK )
+ CALL ZLARF1F( 'L', M-P-Q-I+1, M-P-Q-I, X22(P+I,Q+I),
+ $ 1, CONJG(TAUQ2(P+I)), X22(P+I,Q+I+1),
+ $ LDX22, WORK )
END IF
*
END DO
diff --git a/lapack-netlib/SRC/zunbdb1.f b/lapack-netlib/SRC/zunbdb1.f
index 2fae170de4..d1e1933176 100644
--- a/lapack-netlib/SRC/zunbdb1.f
+++ b/lapack-netlib/SRC/zunbdb1.f
@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
-*> \htmlonly
*> Download ZUNBDB1 + dependencies
*>
*> [TGZ]
@@ -13,7 +12,6 @@
*> [ZIP]
*>
*> [TXT]
-*> \endhtmlonly
*
* Definition:
* ===========
@@ -174,7 +172,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \ingroup complex16OTHERcomputational
+*> \ingroup unbdb1
*
*> \par Further Details:
* =====================
@@ -198,8 +196,10 @@
*> Algorithms, 50(1):33-65, 2009.
*>
* =====================================================================
- SUBROUTINE ZUNBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
+ SUBROUTINE ZUNBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA,
+ $ PHI,
$ TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO )
+ IMPLICIT NONE
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
@@ -227,7 +227,8 @@ SUBROUTINE ZUNBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
LOGICAL LQUERY
* ..
* .. External Subroutines ..
- EXTERNAL ZLARF, ZLARFGP, ZUNBDB5, ZDROT, XERBLA
+ EXTERNAL ZLARF1F, ZLARFGP, ZUNBDB5, ZDROT,
+ $ XERBLA
EXTERNAL ZLACGV
* ..
* .. External Functions ..
@@ -286,27 +287,29 @@ SUBROUTINE ZUNBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
THETA(I) = ATAN2( DBLE( X21(I,I) ), DBLE( X11(I,I) ) )
C = COS( THETA(I) )
S = SIN( THETA(I) )
- X11(I,I) = ONE
- X21(I,I) = ONE
- CALL ZLARF( 'L', P-I+1, Q-I, X11(I,I), 1, DCONJG(TAUP1(I)),
- $ X11(I,I+1), LDX11, WORK(ILARF) )
- CALL ZLARF( 'L', M-P-I+1, Q-I, X21(I,I), 1, DCONJG(TAUP2(I)),
- $ X21(I,I+1), LDX21, WORK(ILARF) )
+ C = COS( THETA(I) )
+ S = SIN( THETA(I) )
+ CALL ZLARF1F( 'L', P-I+1, Q-I, X11(I,I), 1, CONJG(TAUP1(I)),
+ $ X11(I,I+1), LDX11, WORK(ILARF) )
+ CALL ZLARF1F( 'L', M-P-I+1, Q-I, X21(I,I), 1,
+ $ CONJG(TAUP2(I)), X21(I,I+1), LDX21,
+ $ WORK(ILARF) )
*
IF( I .LT. Q ) THEN
CALL ZDROT( Q-I, X11(I,I+1), LDX11, X21(I,I+1), LDX21, C,
$ S )
CALL ZLACGV( Q-I, X21(I,I+1), LDX21 )
- CALL ZLARFGP( Q-I, X21(I,I+1), X21(I,I+2), LDX21, TAUQ1(I) )
+ CALL ZLARFGP( Q-I, X21(I,I+1), X21(I,I+2), LDX21,
+ $ TAUQ1(I) )
S = DBLE( X21(I,I+1) )
- X21(I,I+1) = ONE
- CALL ZLARF( 'R', P-I, Q-I, X21(I,I+1), LDX21, TAUQ1(I),
- $ X11(I+1,I+1), LDX11, WORK(ILARF) )
- CALL ZLARF( 'R', M-P-I, Q-I, X21(I,I+1), LDX21, TAUQ1(I),
- $ X21(I+1,I+1), LDX21, WORK(ILARF) )
+ CALL ZLARF1F( 'R', P-I, Q-I, X21(I,I+1), LDX21, TAUQ1(I),
+ $ X11(I+1,I+1), LDX11, WORK(ILARF) )
+ CALL ZLARF1F( 'R', M-P-I, Q-I, X21(I,I+1), LDX21,
+ $ TAUQ1(I), X21(I+1,I+1), LDX21,
+ $ WORK(ILARF) )
CALL ZLACGV( Q-I, X21(I,I+1), LDX21 )
C = SQRT( DZNRM2( P-I, X11(I+1,I+1), 1 )**2
- $ + DZNRM2( M-P-I, X21(I+1,I+1), 1 )**2 )
+ $ + DZNRM2( M-P-I, X21(I+1,I+1), 1 )**2 )
PHI(I) = ATAN2( S, C )
CALL ZUNBDB5( P-I, M-P-I, Q-I-1, X11(I+1,I+1), 1,
$ X21(I+1,I+1), 1, X11(I+1,I+2), LDX11,
diff --git a/lapack-netlib/SRC/zunbdb2.f b/lapack-netlib/SRC/zunbdb2.f
index 28e78fc23c..f8bc474f3e 100644
--- a/lapack-netlib/SRC/zunbdb2.f
+++ b/lapack-netlib/SRC/zunbdb2.f
@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
-*> \htmlonly
*> Download ZUNBDB2 + dependencies
*>
*> [TGZ]
@@ -13,7 +12,6 @@
*> [ZIP]
*>
*> [TXT]
-*> \endhtmlonly
*
* Definition:
* ===========
@@ -172,7 +170,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \ingroup complex16OTHERcomputational
+*> \ingroup unbdb2
*
*> \par Further Details:
* =====================
@@ -196,8 +194,10 @@
*> Algorithms, 50(1):33-65, 2009.
*>
* =====================================================================
- SUBROUTINE ZUNBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
+ SUBROUTINE ZUNBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA,
+ $ PHI,
$ TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO )
+ IMPLICIT NONE
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
@@ -226,7 +226,8 @@ SUBROUTINE ZUNBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
LOGICAL LQUERY
* ..
* .. External Subroutines ..
- EXTERNAL ZLARF, ZLARFGP, ZUNBDB5, ZDROT, ZSCAL, ZLACGV,
+ EXTERNAL ZLARF1F, ZLARFGP, ZUNBDB5, ZDROT, ZSCAL,
+ $ ZLACGV,
$ XERBLA
* ..
* .. External Functions ..
@@ -287,11 +288,10 @@ SUBROUTINE ZUNBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
CALL ZLACGV( Q-I+1, X11(I,I), LDX11 )
CALL ZLARFGP( Q-I+1, X11(I,I), X11(I,I+1), LDX11, TAUQ1(I) )
C = DBLE( X11(I,I) )
- X11(I,I) = ONE
- CALL ZLARF( 'R', P-I, Q-I+1, X11(I,I), LDX11, TAUQ1(I),
- $ X11(I+1,I), LDX11, WORK(ILARF) )
- CALL ZLARF( 'R', M-P-I+1, Q-I+1, X11(I,I), LDX11, TAUQ1(I),
- $ X21(I,I), LDX21, WORK(ILARF) )
+ CALL ZLARF1F( 'R', P-I, Q-I+1, X11(I,I), LDX11, TAUQ1(I),
+ $ X11(I+1,I), LDX11, WORK(ILARF) )
+ CALL ZLARF1F( 'R', M-P-I+1, Q-I+1, X11(I,I), LDX11,
+ $ TAUQ1(I), X21(I,I), LDX21, WORK(ILARF) )
CALL ZLACGV( Q-I+1, X11(I,I), LDX11 )
S = SQRT( DZNRM2( P-I, X11(I+1,I), 1 )**2
$ + DZNRM2( M-P-I+1, X21(I,I), 1 )**2 )
@@ -307,13 +307,13 @@ SUBROUTINE ZUNBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
PHI(I) = ATAN2( DBLE( X11(I+1,I) ), DBLE( X21(I,I) ) )
C = COS( PHI(I) )
S = SIN( PHI(I) )
- X11(I+1,I) = ONE
- CALL ZLARF( 'L', P-I, Q-I, X11(I+1,I), 1, DCONJG(TAUP1(I)),
- $ X11(I+1,I+1), LDX11, WORK(ILARF) )
+ CALL ZLARF1F( 'L', P-I, Q-I, X11(I+1,I), 1,
+ $ CONJG(TAUP1(I)),
+ $ X11(I+1,I+1), LDX11, WORK(ILARF) )
END IF
- X21(I,I) = ONE
- CALL ZLARF( 'L', M-P-I+1, Q-I, X21(I,I), 1, DCONJG(TAUP2(I)),
- $ X21(I,I+1), LDX21, WORK(ILARF) )
+ CALL ZLARF1F( 'L', M-P-I+1, Q-I, X21(I,I), 1,
+ $ CONJG(TAUP2(I)), X21(I,I+1), LDX21,
+ $ WORK(ILARF) )
*
END DO
*
@@ -321,9 +321,9 @@ SUBROUTINE ZUNBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
*
DO I = P + 1, Q
CALL ZLARFGP( M-P-I+1, X21(I,I), X21(I+1,I), 1, TAUP2(I) )
- X21(I,I) = ONE
- CALL ZLARF( 'L', M-P-I+1, Q-I, X21(I,I), 1, DCONJG(TAUP2(I)),
- $ X21(I,I+1), LDX21, WORK(ILARF) )
+ CALL ZLARF1F( 'L', M-P-I+1, Q-I, X21(I,I), 1,
+ $ CONJG(TAUP2(I)), X21(I,I+1), LDX21,
+ $ WORK(ILARF) )
END DO
*
RETURN
diff --git a/lapack-netlib/SRC/zunbdb3.f b/lapack-netlib/SRC/zunbdb3.f
index 9f32a7a886..f7a9768946 100644
--- a/lapack-netlib/SRC/zunbdb3.f
+++ b/lapack-netlib/SRC/zunbdb3.f
@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
-*> \htmlonly
*> Download ZUNBDB3 + dependencies
*>
*> [TGZ]
@@ -13,7 +12,6 @@
*> [ZIP]
*>
*> [TXT]
-*> \endhtmlonly
*
* Definition:
* ===========
@@ -172,7 +170,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \ingroup complex16OTHERcomputational
+*> \ingroup unbdb3
*
*> \par Further Details:
* =====================
@@ -196,8 +194,10 @@
*> Algorithms, 50(1):33-65, 2009.
*>
* =====================================================================
- SUBROUTINE ZUNBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
+ SUBROUTINE ZUNBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA,
+ $ PHI,
$ TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO )
+ IMPLICIT NONE
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
@@ -225,7 +225,8 @@ SUBROUTINE ZUNBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
LOGICAL LQUERY
* ..
* .. External Subroutines ..
- EXTERNAL ZLARF, ZLARFGP, ZUNBDB5, ZDROT, ZLACGV, XERBLA
+ EXTERNAL ZLARF1F, ZLARFGP, ZUNBDB5, ZDROT, ZLACGV,
+ $ XERBLA
* ..
* .. External Functions ..
DOUBLE PRECISION DZNRM2
@@ -283,14 +284,12 @@ SUBROUTINE ZUNBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
$ S )
END IF
*
- CALL ZLACGV( Q-I+1, X21(I,I), LDX21 )
CALL ZLARFGP( Q-I+1, X21(I,I), X21(I,I+1), LDX21, TAUQ1(I) )
S = DBLE( X21(I,I) )
- X21(I,I) = ONE
- CALL ZLARF( 'R', P-I+1, Q-I+1, X21(I,I), LDX21, TAUQ1(I),
- $ X11(I,I), LDX11, WORK(ILARF) )
- CALL ZLARF( 'R', M-P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I),
- $ X21(I+1,I), LDX21, WORK(ILARF) )
+ CALL ZLARF1F( 'R', P-I+1, Q-I+1, X21(I,I), LDX21, TAUQ1(I),
+ $ X11(I,I), LDX11, WORK(ILARF) )
+ CALL ZLARF1F( 'R', M-P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I),
+ $ X21(I+1,I), LDX21, WORK(ILARF) )
CALL ZLACGV( Q-I+1, X21(I,I), LDX21 )
C = SQRT( DZNRM2( P-I+1, X11(I,I), 1 )**2
$ + DZNRM2( M-P-I, X21(I+1,I), 1 )**2 )
@@ -301,28 +300,25 @@ SUBROUTINE ZUNBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
$ WORK(IORBDB5), LORBDB5, CHILDINFO )
CALL ZLARFGP( P-I+1, X11(I,I), X11(I+1,I), 1, TAUP1(I) )
IF( I .LT. M-P ) THEN
- CALL ZLARFGP( M-P-I, X21(I+1,I), X21(I+2,I), 1, TAUP2(I) )
+ CALL ZLARFGP( M-P-I, X21(I+1,I), X21(I+2,I), 1,
+ $ TAUP2(I) )
PHI(I) = ATAN2( DBLE( X21(I+1,I) ), DBLE( X11(I,I) ) )
C = COS( PHI(I) )
S = SIN( PHI(I) )
- X21(I+1,I) = ONE
- CALL ZLARF( 'L', M-P-I, Q-I, X21(I+1,I), 1,
- $ DCONJG(TAUP2(I)), X21(I+1,I+1), LDX21,
- $ WORK(ILARF) )
+ CALL ZLARF1F( 'L', M-P-I, Q-I, X21(I+1,I), 1,
+ $ CONJG(TAUP2(I)),
+ $ X21(I+1,I+1), LDX21, WORK(ILARF) )
END IF
- X11(I,I) = ONE
- CALL ZLARF( 'L', P-I+1, Q-I, X11(I,I), 1, DCONJG(TAUP1(I)),
- $ X11(I,I+1), LDX11, WORK(ILARF) )
-*
+ CALL ZLARF1F( 'L', P-I+1, Q-I, X11(I,I), 1, CONJG(TAUP1(I)),
+ $ X11(I,I+1), LDX11, WORK(ILARF) )
END DO
*
* Reduce the bottom-right portion of X11 to the identity matrix
*
DO I = M-P + 1, Q
CALL ZLARFGP( P-I+1, X11(I,I), X11(I+1,I), 1, TAUP1(I) )
- X11(I,I) = ONE
- CALL ZLARF( 'L', P-I+1, Q-I, X11(I,I), 1, DCONJG(TAUP1(I)),
- $ X11(I,I+1), LDX11, WORK(ILARF) )
+ CALL ZLARF1F( 'L', P-I+1, Q-I, X11(I,I), 1, CONJG(TAUP1(I)),
+ $ X11(I,I+1), LDX11, WORK(ILARF) )
END DO
*
RETURN
diff --git a/lapack-netlib/SRC/zunbdb4.f b/lapack-netlib/SRC/zunbdb4.f
index a1db5eb793..31d8ec40b7 100644
--- a/lapack-netlib/SRC/zunbdb4.f
+++ b/lapack-netlib/SRC/zunbdb4.f
@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
-*> \htmlonly
*> Download ZUNBDB4 + dependencies
*>
*> [TGZ]
@@ -13,7 +12,6 @@
*> [ZIP]
*>
*> [TXT]
-*> \endhtmlonly
*
* Definition:
* ===========
@@ -183,7 +181,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \ingroup complex16OTHERcomputational
+*> \ingroup unbdb4
*
*> \par Further Details:
* =====================
@@ -207,9 +205,11 @@
*> Algorithms, 50(1):33-65, 2009.
*>
* =====================================================================
- SUBROUTINE ZUNBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
+ SUBROUTINE ZUNBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA,
+ $ PHI,
$ TAUP1, TAUP2, TAUQ1, PHANTOM, WORK, LWORK,
$ INFO )
+ IMPLICIT NONE
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
@@ -238,7 +238,8 @@ SUBROUTINE ZUNBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
LOGICAL LQUERY
* ..
* .. External Subroutines ..
- EXTERNAL ZLARF, ZLARFGP, ZUNBDB5, ZDROT, ZSCAL, ZLACGV,
+ EXTERNAL ZLARF1F, ZLARFGP, ZUNBDB5, ZDROT, ZSCAL,
+ $ ZLACGV,
$ XERBLA
* ..
* .. External Functions ..
@@ -302,44 +303,45 @@ SUBROUTINE ZUNBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
$ LORBDB5, CHILDINFO )
CALL ZSCAL( P, NEGONE, PHANTOM(1), 1 )
CALL ZLARFGP( P, PHANTOM(1), PHANTOM(2), 1, TAUP1(1) )
- CALL ZLARFGP( M-P, PHANTOM(P+1), PHANTOM(P+2), 1, TAUP2(1) )
+ CALL ZLARFGP( M-P, PHANTOM(P+1), PHANTOM(P+2), 1,
+ $ TAUP2(1) )
THETA(I) = ATAN2( DBLE( PHANTOM(1) ), DBLE( PHANTOM(P+1) ) )
C = COS( THETA(I) )
S = SIN( THETA(I) )
- PHANTOM(1) = ONE
- PHANTOM(P+1) = ONE
- CALL ZLARF( 'L', P, Q, PHANTOM(1), 1, DCONJG(TAUP1(1)), X11,
- $ LDX11, WORK(ILARF) )
- CALL ZLARF( 'L', M-P, Q, PHANTOM(P+1), 1, DCONJG(TAUP2(1)),
- $ X21, LDX21, WORK(ILARF) )
+ CALL ZLARF1F( 'L', P, Q, PHANTOM(1), 1, CONJG(TAUP1(1)),
+ $ X11,
+ $ LDX11, WORK(ILARF) )
+ CALL ZLARF1F( 'L', M-P, Q, PHANTOM(P+1), 1,
+ $ CONJG(TAUP2(1)),
+ $ X21, LDX21, WORK(ILARF) )
ELSE
CALL ZUNBDB5( P-I+1, M-P-I+1, Q-I+1, X11(I,I-1), 1,
$ X21(I,I-1), 1, X11(I,I), LDX11, X21(I,I),
$ LDX21, WORK(IORBDB5), LORBDB5, CHILDINFO )
CALL ZSCAL( P-I+1, NEGONE, X11(I,I-1), 1 )
- CALL ZLARFGP( P-I+1, X11(I,I-1), X11(I+1,I-1), 1, TAUP1(I) )
+ CALL ZLARFGP( P-I+1, X11(I,I-1), X11(I+1,I-1), 1,
+ $ TAUP1(I) )
CALL ZLARFGP( M-P-I+1, X21(I,I-1), X21(I+1,I-1), 1,
$ TAUP2(I) )
THETA(I) = ATAN2( DBLE( X11(I,I-1) ), DBLE( X21(I,I-1) ) )
C = COS( THETA(I) )
S = SIN( THETA(I) )
- X11(I,I-1) = ONE
- X21(I,I-1) = ONE
- CALL ZLARF( 'L', P-I+1, Q-I+1, X11(I,I-1), 1,
- $ DCONJG(TAUP1(I)), X11(I,I), LDX11, WORK(ILARF) )
- CALL ZLARF( 'L', M-P-I+1, Q-I+1, X21(I,I-1), 1,
- $ DCONJG(TAUP2(I)), X21(I,I), LDX21, WORK(ILARF) )
+ CALL ZLARF1F( 'L', P-I+1, Q-I+1, X11(I,I-1), 1,
+ $ CONJG(TAUP1(I)), X11(I,I), LDX11,
+ $ WORK(ILARF) )
+ CALL ZLARF1F( 'L', M-P-I+1, Q-I+1, X21(I,I-1), 1,
+ $ CONJG(TAUP2(I)), X21(I,I), LDX21,
+ $ WORK(ILARF) )
END IF
*
CALL ZDROT( Q-I+1, X11(I,I), LDX11, X21(I,I), LDX21, S, -C )
CALL ZLACGV( Q-I+1, X21(I,I), LDX21 )
CALL ZLARFGP( Q-I+1, X21(I,I), X21(I,I+1), LDX21, TAUQ1(I) )
C = DBLE( X21(I,I) )
- X21(I,I) = ONE
- CALL ZLARF( 'R', P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I),
- $ X11(I+1,I), LDX11, WORK(ILARF) )
- CALL ZLARF( 'R', M-P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I),
- $ X21(I+1,I), LDX21, WORK(ILARF) )
+ CALL ZLARF1F( 'R', P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I),
+ $ X11(I+1,I), LDX11, WORK(ILARF) )
+ CALL ZLARF1F( 'R', M-P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I),
+ $ X21(I+1,I), LDX21, WORK(ILARF) )
CALL ZLACGV( Q-I+1, X21(I,I), LDX21 )
IF( I .LT. M-Q ) THEN
S = SQRT( DZNRM2( P-I, X11(I+1,I), 1 )**2
@@ -354,11 +356,10 @@ SUBROUTINE ZUNBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
DO I = M - Q + 1, P
CALL ZLACGV( Q-I+1, X11(I,I), LDX11 )
CALL ZLARFGP( Q-I+1, X11(I,I), X11(I,I+1), LDX11, TAUQ1(I) )
- X11(I,I) = ONE
- CALL ZLARF( 'R', P-I, Q-I+1, X11(I,I), LDX11, TAUQ1(I),
- $ X11(I+1,I), LDX11, WORK(ILARF) )
- CALL ZLARF( 'R', Q-P, Q-I+1, X11(I,I), LDX11, TAUQ1(I),
- $ X21(M-Q+1,I), LDX21, WORK(ILARF) )
+ CALL ZLARF1F( 'R', P-I, Q-I+1, X11(I,I), LDX11, TAUQ1(I),
+ $ X11(I+1,I), LDX11, WORK(ILARF) )
+ CALL ZLARF1F( 'R', Q-P, Q-I+1, X11(I,I), LDX11, TAUQ1(I),
+ $ X21(M-Q+1,I), LDX21, WORK(ILARF) )
CALL ZLACGV( Q-I+1, X11(I,I), LDX11 )
END DO
*
@@ -366,11 +367,12 @@ SUBROUTINE ZUNBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
*
DO I = P + 1, Q
CALL ZLACGV( Q-I+1, X21(M-Q+I-P,I), LDX21 )
- CALL ZLARFGP( Q-I+1, X21(M-Q+I-P,I), X21(M-Q+I-P,I+1), LDX21,
+ CALL ZLARFGP( Q-I+1, X21(M-Q+I-P,I), X21(M-Q+I-P,I+1),
+ $ LDX21,
$ TAUQ1(I) )
- X21(M-Q+I-P,I) = ONE
- CALL ZLARF( 'R', Q-I, Q-I+1, X21(M-Q+I-P,I), LDX21, TAUQ1(I),
- $ X21(M-Q+I-P+1,I), LDX21, WORK(ILARF) )
+ CALL ZLARF1F( 'R', Q-I, Q-I+1, X21(M-Q+I-P,I), LDX21,
+ $ TAUQ1(I),
+ $ X21(M-Q+I-P+1,I), LDX21, WORK(ILARF) )
CALL ZLACGV( Q-I+1, X21(M-Q+I-P,I), LDX21 )
END DO
*
diff --git a/lapack-netlib/SRC/zung2l.f b/lapack-netlib/SRC/zung2l.f
index add5cb946b..7f5cf64b00 100644
--- a/lapack-netlib/SRC/zung2l.f
+++ b/lapack-netlib/SRC/zung2l.f
@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
-*> \htmlonly
*> Download ZUNG2L + dependencies
*>
*> [TGZ]
@@ -13,7 +12,6 @@
*> [ZIP]
*>
*> [TXT]
-*> \endhtmlonly
*
* Definition:
* ===========
@@ -107,10 +105,11 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \ingroup complex16OTHERcomputational
+*> \ingroup ung2l
*
* =====================================================================
SUBROUTINE ZUNG2L( M, N, K, A, LDA, TAU, WORK, INFO )
+ IMPLICIT NONE
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
@@ -134,7 +133,7 @@ SUBROUTINE ZUNG2L( M, N, K, A, LDA, TAU, WORK, INFO )
INTEGER I, II, J, L
* ..
* .. External Subroutines ..
- EXTERNAL XERBLA, ZLARF, ZSCAL
+ EXTERNAL XERBLA, ZLARF1L, ZSCAL
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
@@ -178,8 +177,9 @@ SUBROUTINE ZUNG2L( M, N, K, A, LDA, TAU, WORK, INFO )
* Apply H(i) to A(1:m-k+i,1:n-k+i) from the left
*
A( M-N+II, II ) = ONE
- CALL ZLARF( 'Left', M-N+II, II-1, A( 1, II ), 1, TAU( I ), A,
- $ LDA, WORK )
+ CALL ZLARF1L( 'Left', M-N+II, II-1, A( 1, II ), 1, TAU( I ),
+ $ A,
+ $ LDA, WORK )
CALL ZSCAL( M-N+II-1, -TAU( I ), A( 1, II ), 1 )
A( M-N+II, II ) = ONE - TAU( I )
*
diff --git a/lapack-netlib/SRC/zung2r.f b/lapack-netlib/SRC/zung2r.f
index 2823b7ebdd..56374be425 100644
--- a/lapack-netlib/SRC/zung2r.f
+++ b/lapack-netlib/SRC/zung2r.f
@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
-*> \htmlonly
*> Download ZUNG2R + dependencies
*>
*> [TGZ]
@@ -13,7 +12,6 @@
*> [ZIP]
*>
*> [TXT]
-*> \endhtmlonly
*
* Definition:
* ===========
@@ -107,10 +105,11 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \ingroup complex16OTHERcomputational
+*> \ingroup ung2r
*
* =====================================================================
SUBROUTINE ZUNG2R( M, N, K, A, LDA, TAU, WORK, INFO )
+ IMPLICIT NONE
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
@@ -134,7 +133,7 @@ SUBROUTINE ZUNG2R( M, N, K, A, LDA, TAU, WORK, INFO )
INTEGER I, J, L
* ..
* .. External Subroutines ..
- EXTERNAL XERBLA, ZLARF, ZSCAL
+ EXTERNAL XERBLA, ZLARF1F, ZSCAL
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
@@ -177,9 +176,8 @@ SUBROUTINE ZUNG2R( M, N, K, A, LDA, TAU, WORK, INFO )
* Apply H(i) to A(i:m,i:n) from the left
*
IF( I.LT.N ) THEN
- A( I, I ) = ONE
- CALL ZLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ),
- $ A( I, I+1 ), LDA, WORK )
+ CALL ZLARF1F( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ),
+ $ A( I, I+1 ), LDA, WORK )
END IF
IF( I.LT.M )
$ CALL ZSCAL( M-I, -TAU( I ), A( I+1, I ), 1 )
diff --git a/lapack-netlib/SRC/zungl2.f b/lapack-netlib/SRC/zungl2.f
index e7a0b59603..24f41b9be8 100644
--- a/lapack-netlib/SRC/zungl2.f
+++ b/lapack-netlib/SRC/zungl2.f
@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
-*> \htmlonly
*> Download ZUNGL2 + dependencies
*>
*> [TGZ]
@@ -13,7 +12,6 @@
*> [ZIP]
*>
*> [TXT]
-*> \endhtmlonly
*
* Definition:
* ===========
@@ -106,10 +104,11 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \ingroup complex16OTHERcomputational
+*> \ingroup ungl2
*
* =====================================================================
SUBROUTINE ZUNGL2( M, N, K, A, LDA, TAU, WORK, INFO )
+ IMPLICIT NONE
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
@@ -133,7 +132,7 @@ SUBROUTINE ZUNGL2( M, N, K, A, LDA, TAU, WORK, INFO )
INTEGER I, J, L
* ..
* .. External Subroutines ..
- EXTERNAL XERBLA, ZLACGV, ZLARF, ZSCAL
+ EXTERNAL XERBLA, ZLACGV, ZLARF1F, ZSCAL
* ..
* .. Intrinsic Functions ..
INTRINSIC DCONJG, MAX
@@ -182,9 +181,9 @@ SUBROUTINE ZUNGL2( M, N, K, A, LDA, TAU, WORK, INFO )
IF( I.LT.N ) THEN
CALL ZLACGV( N-I, A( I, I+1 ), LDA )
IF( I.LT.M ) THEN
- A( I, I ) = ONE
- CALL ZLARF( 'Right', M-I, N-I+1, A( I, I ), LDA,
- $ DCONJG( TAU( I ) ), A( I+1, I ), LDA, WORK )
+ CALL ZLARF1F( 'Right', M-I, N-I+1, A( I, I ), LDA,
+ $ CONJG( TAU( I ) ), A( I+1, I ), LDA,
+ $ WORK )
END IF
CALL ZSCAL( N-I, -TAU( I ), A( I, I+1 ), LDA )
CALL ZLACGV( N-I, A( I, I+1 ), LDA )
diff --git a/lapack-netlib/SRC/zungr2.f b/lapack-netlib/SRC/zungr2.f
index 034ff4fe41..f24a455fe6 100644
--- a/lapack-netlib/SRC/zungr2.f
+++ b/lapack-netlib/SRC/zungr2.f
@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
-*> \htmlonly
*> Download ZUNGR2 + dependencies
*>
*> [TGZ]
@@ -13,7 +12,6 @@
*> [ZIP]
*>
*> [TXT]
-*> \endhtmlonly
*
* Definition:
* ===========
@@ -107,10 +105,11 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \ingroup complex16OTHERcomputational
+*> \ingroup ungr2
*
* =====================================================================
SUBROUTINE ZUNGR2( M, N, K, A, LDA, TAU, WORK, INFO )
+ IMPLICIT NONE
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
@@ -134,7 +133,7 @@ SUBROUTINE ZUNGR2( M, N, K, A, LDA, TAU, WORK, INFO )
INTEGER I, II, J, L
* ..
* .. External Subroutines ..
- EXTERNAL XERBLA, ZLACGV, ZLARF, ZSCAL
+ EXTERNAL XERBLA, ZLACGV, ZLARF1L, ZSCAL
* ..
* .. Intrinsic Functions ..
INTRINSIC DCONJG, MAX
@@ -182,9 +181,8 @@ SUBROUTINE ZUNGR2( M, N, K, A, LDA, TAU, WORK, INFO )
* Apply H(i)**H to A(1:m-k+i,1:n-k+i) from the right
*
CALL ZLACGV( N-M+II-1, A( II, 1 ), LDA )
- A( II, N-M+II ) = ONE
- CALL ZLARF( 'Right', II-1, N-M+II, A( II, 1 ), LDA,
- $ DCONJG( TAU( I ) ), A, LDA, WORK )
+ CALL ZLARF1L( 'Right', II-1, N-M+II, A( II, 1 ), LDA,
+ $ CONJG( TAU( I ) ), A, LDA, WORK )
CALL ZSCAL( N-M+II-1, -TAU( I ), A( II, 1 ), LDA )
CALL ZLACGV( N-M+II-1, A( II, 1 ), LDA )
A( II, N-M+II ) = ONE - DCONJG( TAU( I ) )
diff --git a/lapack-netlib/SRC/zunm2l.f b/lapack-netlib/SRC/zunm2l.f
index 48c2dbfc0c..2756bf9811 100644
--- a/lapack-netlib/SRC/zunm2l.f
+++ b/lapack-netlib/SRC/zunm2l.f
@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
-*> \htmlonly
*> Download ZUNM2L + dependencies
*>
*> [TGZ]
@@ -13,7 +12,6 @@
*> [ZIP]
*>
*> [TXT]
-*> \endhtmlonly
*
* Definition:
* ===========
@@ -151,11 +149,12 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \ingroup complex16OTHERcomputational
+*> \ingroup unm2l
*
* =====================================================================
SUBROUTINE ZUNM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
$ WORK, INFO )
+ IMPLICIT NONE
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
@@ -178,14 +177,14 @@ SUBROUTINE ZUNM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
* .. Local Scalars ..
LOGICAL LEFT, NOTRAN
INTEGER I, I1, I2, I3, MI, NI, NQ
- COMPLEX*16 AII, TAUI
+ COMPLEX*16 TAUI
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
- EXTERNAL XERBLA, ZLARF
+ EXTERNAL XERBLA, ZLARF1L
* ..
* .. Intrinsic Functions ..
INTRINSIC DCONJG, MAX
@@ -266,10 +265,8 @@ SUBROUTINE ZUNM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
ELSE
TAUI = DCONJG( TAU( I ) )
END IF
- AII = A( NQ-K+I, I )
- A( NQ-K+I, I ) = ONE
- CALL ZLARF( SIDE, MI, NI, A( 1, I ), 1, TAUI, C, LDC, WORK )
- A( NQ-K+I, I ) = AII
+ CALL ZLARF1L( SIDE, MI, NI, A( 1, I ), 1, TAUI, C, LDC,
+ $ WORK )
10 CONTINUE
RETURN
*
diff --git a/lapack-netlib/SRC/zunm2r.f b/lapack-netlib/SRC/zunm2r.f
index aec5a8bcae..8e42228a7f 100644
--- a/lapack-netlib/SRC/zunm2r.f
+++ b/lapack-netlib/SRC/zunm2r.f
@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
-*> \htmlonly
*> Download ZUNM2R + dependencies
*>
*> [TGZ]
@@ -13,7 +12,6 @@
*> [ZIP]
*>
*> [TXT]
-*> \endhtmlonly
*
* Definition:
* ===========
@@ -151,11 +149,12 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \ingroup complex16OTHERcomputational
+*> \ingroup unm2r
*
* =====================================================================
SUBROUTINE ZUNM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
$ WORK, INFO )
+ IMPLICIT NONE
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
@@ -178,14 +177,14 @@ SUBROUTINE ZUNM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
* .. Local Scalars ..
LOGICAL LEFT, NOTRAN
INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ
- COMPLEX*16 AII, TAUI
+ COMPLEX*16 TAUI
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
- EXTERNAL XERBLA, ZLARF
+ EXTERNAL XERBLA, ZLARF1F
* ..
* .. Intrinsic Functions ..
INTRINSIC DCONJG, MAX
@@ -270,11 +269,9 @@ SUBROUTINE ZUNM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
ELSE
TAUI = DCONJG( TAU( I ) )
END IF
- AII = A( I, I )
- A( I, I ) = ONE
- CALL ZLARF( SIDE, MI, NI, A( I, I ), 1, TAUI, C( IC, JC ), LDC,
+ CALL ZLARF1F( SIDE, MI, NI, A( I, I ), 1, TAUI, C( IC, JC ),
+ $ LDC,
$ WORK )
- A( I, I ) = AII
10 CONTINUE
RETURN
*
diff --git a/lapack-netlib/SRC/zunml2.f b/lapack-netlib/SRC/zunml2.f
index f47f768b08..969d586d17 100644
--- a/lapack-netlib/SRC/zunml2.f
+++ b/lapack-netlib/SRC/zunml2.f
@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
-*> \htmlonly
*> Download ZUNML2 + dependencies
*>
*> [TGZ]
@@ -13,7 +12,6 @@
*> [ZIP]
*>
*> [TXT]
-*> \endhtmlonly
*
* Definition:
* ===========
@@ -151,11 +149,12 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \ingroup complex16OTHERcomputational
+*> \ingroup unml2
*
* =====================================================================
SUBROUTINE ZUNML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
$ WORK, INFO )
+ IMPLICIT NONE
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
@@ -178,14 +177,14 @@ SUBROUTINE ZUNML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
* .. Local Scalars ..
LOGICAL LEFT, NOTRAN
INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ
- COMPLEX*16 AII, TAUI
+ COMPLEX*16 TAUI
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
- EXTERNAL XERBLA, ZLACGV, ZLARF
+ EXTERNAL XERBLA, ZLACGV, ZLARF1F
* ..
* .. Intrinsic Functions ..
INTRINSIC DCONJG, MAX
@@ -272,11 +271,8 @@ SUBROUTINE ZUNML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
END IF
IF( I.LT.NQ )
$ CALL ZLACGV( NQ-I, A( I, I+1 ), LDA )
- AII = A( I, I )
- A( I, I ) = ONE
- CALL ZLARF( SIDE, MI, NI, A( I, I ), LDA, TAUI, C( IC, JC ),
- $ LDC, WORK )
- A( I, I ) = AII
+ CALL ZLARF1F( SIDE, MI, NI, A( I, I ), LDA, TAUI, C( IC,
+ $ JC ), LDC, WORK )
IF( I.LT.NQ )
$ CALL ZLACGV( NQ-I, A( I, I+1 ), LDA )
10 CONTINUE
diff --git a/lapack-netlib/SRC/zunmr2.f b/lapack-netlib/SRC/zunmr2.f
index 3685e9c7c6..6696a7f8f2 100644
--- a/lapack-netlib/SRC/zunmr2.f
+++ b/lapack-netlib/SRC/zunmr2.f
@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
-*> \htmlonly
*> Download ZUNMR2 + dependencies
*>
*> [TGZ]
@@ -13,7 +12,6 @@
*> [ZIP]
*>
*> [TXT]
-*> \endhtmlonly
*
* Definition:
* ===========
@@ -151,11 +149,12 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \ingroup complex16OTHERcomputational
+*> \ingroup unmr2
*
* =====================================================================
SUBROUTINE ZUNMR2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
$ WORK, INFO )
+ IMPLICIT NONE
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
@@ -178,14 +177,14 @@ SUBROUTINE ZUNMR2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
* .. Local Scalars ..
LOGICAL LEFT, NOTRAN
INTEGER I, I1, I2, I3, MI, NI, NQ
- COMPLEX*16 AII, TAUI
+ COMPLEX*16 TAUI
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
- EXTERNAL XERBLA, ZLACGV, ZLARF
+ EXTERNAL XERBLA, ZLACGV, ZLARF1L
* ..
* .. Intrinsic Functions ..
INTRINSIC DCONJG, MAX
@@ -267,10 +266,8 @@ SUBROUTINE ZUNMR2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
TAUI = TAU( I )
END IF
CALL ZLACGV( NQ-K+I-1, A( I, 1 ), LDA )
- AII = A( I, NQ-K+I )
- A( I, NQ-K+I ) = ONE
- CALL ZLARF( SIDE, MI, NI, A( I, 1 ), LDA, TAUI, C, LDC, WORK )
- A( I, NQ-K+I ) = AII
+ CALL ZLARF1L( SIDE, MI, NI, A( I, 1 ), LDA, TAUI, C, LDC,
+ $ WORK )
CALL ZLACGV( NQ-K+I-1, A( I, 1 ), LDA )
10 CONTINUE
RETURN
diff --git a/lapack-netlib/SRC/zupmtr.f b/lapack-netlib/SRC/zupmtr.f
index c195800261..b37f4b182d 100644
--- a/lapack-netlib/SRC/zupmtr.f
+++ b/lapack-netlib/SRC/zupmtr.f
@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
-*> \htmlonly
*> Download ZUPMTR + dependencies
*>
*> [TGZ]
@@ -13,7 +12,6 @@
*> [ZIP]
*>
*> [TXT]
-*> \endhtmlonly
*
* Definition:
* ===========
@@ -142,11 +140,13 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \ingroup complex16OTHERcomputational
+*> \ingroup upmtr
*
* =====================================================================
- SUBROUTINE ZUPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC, WORK,
+ SUBROUTINE ZUPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC,
+ $ WORK,
$ INFO )
+ IMPLICIT NONE
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
@@ -169,14 +169,14 @@ SUBROUTINE ZUPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC, WORK,
* .. Local Scalars ..
LOGICAL FORWRD, LEFT, NOTRAN, UPPER
INTEGER I, I1, I2, I3, IC, II, JC, MI, NI, NQ
- COMPLEX*16 AII, TAUI
+ COMPLEX*16 TAUI
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
- EXTERNAL XERBLA, ZLARF
+ EXTERNAL XERBLA, ZLARF1, ZLARF1F
* ..
* .. Intrinsic Functions ..
INTRINSIC DCONJG, MAX
@@ -265,11 +265,8 @@ SUBROUTINE ZUPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC, WORK,
ELSE
TAUI = DCONJG( TAU( I ) )
END IF
- AII = AP( II )
- AP( II ) = ONE
- CALL ZLARF( SIDE, MI, NI, AP( II-I+1 ), 1, TAUI, C, LDC,
- $ WORK )
- AP( II ) = AII
+ CALL ZLARF1L( SIDE, MI, NI, AP( II-I+1 ), 1, TAUI, C,
+ $ LDC, WORK )
*
IF( FORWRD ) THEN
II = II + I + 2
@@ -305,8 +302,6 @@ SUBROUTINE ZUPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC, WORK,
END IF
*
DO 20 I = I1, I2, I3
- AII = AP( II )
- AP( II ) = ONE
IF( LEFT ) THEN
*
* H(i) or H(i)**H is applied to C(i+1:m,1:n)
@@ -328,9 +323,8 @@ SUBROUTINE ZUPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC, WORK,
ELSE
TAUI = DCONJG( TAU( I ) )
END IF
- CALL ZLARF( SIDE, MI, NI, AP( II ), 1, TAUI, C( IC, JC ),
- $ LDC, WORK )
- AP( II ) = AII
+ CALL ZLARF1F( SIDE, MI, NI, AP( II ), 1, TAUI, C( IC,
+ $ JC ), LDC, WORK )
*
IF( FORWRD ) THEN
II = II + NQ - I + 1