--- rpl/lapack/lapack/ztgex2.f 2012/12/14 14:22:55 1.14
+++ rpl/lapack/lapack/ztgex2.f 2023/08/07 08:39:40 1.21
@@ -2,25 +2,25 @@
*
* =========== DOCUMENTATION ===========
*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
-*> Download ZTGEX2 + dependencies
-*>
-*> [TGZ]
-*>
-*> [ZIP]
-*>
+*> Download ZTGEX2 + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
*> [TXT]
-*> \endhtmlonly
+*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z,
* LDZ, J1, INFO )
-*
+*
* .. Scalar Arguments ..
* LOGICAL WANTQ, WANTZ
* INTEGER INFO, J1, LDA, LDB, LDQ, LDZ, N
@@ -29,7 +29,7 @@
* COMPLEX*16 A( LDA, * ), B( LDB, * ), Q( LDQ, * ),
* $ Z( LDZ, * )
* ..
-*
+*
*
*> \par Purpose:
* =============
@@ -76,7 +76,7 @@
*>
*> \param[in,out] A
*> \verbatim
-*> A is COMPLEX*16 arrays, dimensions (LDA,N)
+*> A is COMPLEX*16 array, dimensions (LDA,N)
*> On entry, the matrix A in the pair (A, B).
*> On exit, the updated matrix A.
*> \endverbatim
@@ -89,7 +89,7 @@
*>
*> \param[in,out] B
*> \verbatim
-*> B is COMPLEX*16 arrays, dimensions (LDB,N)
+*> B is COMPLEX*16 array, dimensions (LDB,N)
*> On entry, the matrix B in the pair (A, B).
*> On exit, the updated matrix B.
*> \endverbatim
@@ -102,7 +102,7 @@
*>
*> \param[in,out] Q
*> \verbatim
-*> Q is COMPLEX*16 array, dimension (LDZ,N)
+*> Q is COMPLEX*16 array, dimension (LDQ,N)
*> If WANTQ = .TRUE, on entry, the unitary matrix Q. On exit,
*> the updated matrix Q.
*> Not referenced if WANTQ = .FALSE..
@@ -142,18 +142,16 @@
*> =0: Successful exit.
*> =1: The transformed matrix pair (A, B) would be too far
*> from generalized Schur form; the problem is ill-
-*> conditioned.
+*> conditioned.
*> \endverbatim
*
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
-*
-*> \date September 2012
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
*> \ingroup complex16GEauxiliary
*
@@ -190,10 +188,9 @@
SUBROUTINE ZTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z,
$ LDZ, J1, INFO )
*
-* -- LAPACK auxiliary routine (version 3.4.2) --
+* -- LAPACK auxiliary routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* September 2012
*
* .. Scalar Arguments ..
LOGICAL WANTQ, WANTZ
@@ -218,10 +215,10 @@
PARAMETER ( WANDS = .TRUE. )
* ..
* .. Local Scalars ..
- LOGICAL DTRONG, WEAK
+ LOGICAL STRONG, WEAK
INTEGER I, M
- DOUBLE PRECISION CQ, CZ, EPS, SA, SB, SCALE, SMLNUM, SS, SUM,
- $ THRESH, WS
+ DOUBLE PRECISION CQ, CZ, EPS, SA, SB, SCALE, SMLNUM, SUM,
+ $ THRESHA, THRESHB
COMPLEX*16 CDUM, F, G, SQ, SZ
* ..
* .. Local Arrays ..
@@ -248,7 +245,7 @@
*
M = LDST
WEAK = .FALSE.
- DTRONG = .FALSE.
+ STRONG = .FALSE.
*
* Make a local copy of selected block in (A, B)
*
@@ -263,10 +260,14 @@
SUM = DBLE( CONE )
CALL ZLACPY( 'Full', M, M, S, LDST, WORK, M )
CALL ZLACPY( 'Full', M, M, T, LDST, WORK( M*M+1 ), M )
- CALL ZLASSQ( 2*M*M, WORK, 1, SCALE, SUM )
+ CALL ZLASSQ( M*M, WORK, 1, SCALE, SUM )
SA = SCALE*SQRT( SUM )
+ SCALE = DBLE( CZERO )
+ SUM = DBLE( CONE )
+ CALL ZLASSQ( M*M, WORK(M*M+1), 1, SCALE, SUM )
+ SB = SCALE*SQRT( SUM )
*
-* THRES has been changed from
+* THRES has been changed from
* THRESH = MAX( TEN*EPS*SA, SMLNUM )
* to
* THRESH = MAX( TWENTY*EPS*SA, SMLNUM )
@@ -274,15 +275,16 @@
* "Bug" reported by Ondra Kamenik, confirmed by Julie Langou, fixed by
* Jim Demmel and Guillaume Revy. See forum post 1783.
*
- THRESH = MAX( TWENTY*EPS*SA, SMLNUM )
+ THRESHA = MAX( TWENTY*EPS*SA, SMLNUM )
+ THRESHB = MAX( TWENTY*EPS*SB, SMLNUM )
*
* Compute unitary QL and RQ that swap 1-by-1 and 1-by-1 blocks
* using Givens rotations and perform the swap tentatively.
*
F = S( 2, 2 )*T( 1, 1 ) - T( 2, 2 )*S( 1, 1 )
G = S( 2, 2 )*T( 1, 2 ) - T( 2, 2 )*S( 1, 2 )
- SA = ABS( S( 2, 2 ) )
- SB = ABS( T( 2, 2 ) )
+ SA = ABS( S( 2, 2 ) ) * ABS( T( 1, 1 ) )
+ SB = ABS( S( 1, 1 ) ) * ABS( T( 2, 2 ) )
CALL ZLARTG( G, F, CZ, SZ, CDUM )
SZ = -SZ
CALL ZROT( 2, S( 1, 1 ), 1, S( 1, 2 ), 1, CZ, DCONJG( SZ ) )
@@ -295,17 +297,20 @@
CALL ZROT( 2, S( 1, 1 ), LDST, S( 2, 1 ), LDST, CQ, SQ )
CALL ZROT( 2, T( 1, 1 ), LDST, T( 2, 1 ), LDST, CQ, SQ )
*
-* Weak stability test: |S21| + |T21| <= O(EPS F-norm((S, T)))
+* Weak stability test: |S21| <= O(EPS F-norm((A)))
+* and |T21| <= O(EPS F-norm((B)))
*
- WS = ABS( S( 2, 1 ) ) + ABS( T( 2, 1 ) )
- WEAK = WS.LE.THRESH
+ WEAK = ABS( S( 2, 1 ) ).LE.THRESHA .AND.
+ $ ABS( T( 2, 1 ) ).LE.THRESHB
IF( .NOT.WEAK )
$ GO TO 20
*
IF( WANDS ) THEN
*
* Strong stability test:
-* F-norm((A-QL**H*S*QR, B-QL**H*T*QR)) <= O(EPS*F-norm((A, B)))
+* F-norm((A-QL**H*S*QR)) <= O(EPS*F-norm((A)))
+* and
+* F-norm((B-QL**H*T*QR)) <= O(EPS*F-norm((B)))
*
CALL ZLACPY( 'Full', M, M, S, LDST, WORK, M )
CALL ZLACPY( 'Full', M, M, T, LDST, WORK( M*M+1 ), M )
@@ -321,10 +326,14 @@
10 CONTINUE
SCALE = DBLE( CZERO )
SUM = DBLE( CONE )
- CALL ZLASSQ( 2*M*M, WORK, 1, SCALE, SUM )
- SS = SCALE*SQRT( SUM )
- DTRONG = SS.LE.THRESH
- IF( .NOT.DTRONG )
+ CALL ZLASSQ( M*M, WORK, 1, SCALE, SUM )
+ SA = SCALE*SQRT( SUM )
+ SCALE = DBLE( CZERO )
+ SUM = DBLE( CONE )
+ CALL ZLASSQ( M*M, WORK(M*M+1), 1, SCALE, SUM )
+ SB = SCALE*SQRT( SUM )
+ STRONG = SA.LE.THRESHA .AND. SB.LE.THRESHB
+ IF( .NOT.STRONG )
$ GO TO 20
END IF
*