OpenMathLib/OpenBLAS
1
0
Fork 0
mirror of https://github.com/OpenMathLib/OpenBLAS synced 2026-05-31 00:45:48 +08:00
Code Issues Actions 1 Packages Projects Releases Wiki Activity

Merge pull request #5734 from martin-frbg/lapack774
Some checks failed
apple m / build (cmake, gfortran, 0, 0) (push) Has been cancelled
Details
apple m / build (cmake, gfortran, 0, 1) (push) Has been cancelled
Details
apple m / build (cmake, gfortran, 1, 0) (push) Has been cancelled
Details
apple m / build (cmake, gfortran, 1, 1) (push) Has been cancelled
Details
apple m / build (make, gfortran, 0, 0) (push) Has been cancelled
Details
apple m / build (make, gfortran, 0, 1) (push) Has been cancelled
Details
apple m / build (make, gfortran, 1, 0) (push) Has been cancelled
Details
apple m / build (make, gfortran, 1, 1) (push) Has been cancelled
Details
arm64 graviton cirun / build (cmake, gfortran) (push) Has been cancelled
Details
arm64 graviton cirun / build (make, gfortran) (push) Has been cancelled
Details
c910v qemu test / TEST (riscv64-linux-gnu, NO_SHARED=1 TARGET=C910V, C910V, riscv64-unknown-linux-gnu) (push) Has been cancelled
Details
c910v qemu test / TEST (riscv64-linux-gnu, NO_SHARED=1 TARGET=RISCV64_GENERIC, RISCV64_GENERIC, riscv64-linux-gnu) (push) Has been cancelled
Details
Run codspeed benchmarks / benchmarks (make, gfortran, ubuntu-22.04, 3.12) (push) Has been cancelled
Details
Publish docs via GitHub Pages / Deploy docs (push) Has been cancelled
Details
continuous build / build (cmake, clang, flang, ubuntu-latest) (push) Has been cancelled
Details
continuous build / build (cmake, clang, gfortran, macos-latest) (push) Has been cancelled
Details
continuous build / build (cmake, clang, gfortran, ubuntu-24.04-arm) (push) Has been cancelled
Details
continuous build / build (cmake, clang, gfortran, ubuntu-latest) (push) Has been cancelled
Details
continuous build / build (cmake, clang-21, flang, ubuntu-latest) (push) Has been cancelled
Details
continuous build / build (cmake, clang-21, gfortran, ubuntu-24.04-arm) (push) Has been cancelled
Details
continuous build / build (cmake, clang-21, gfortran, ubuntu-latest) (push) Has been cancelled
Details
continuous build / build (cmake, gcc, flang, ubuntu-latest) (push) Has been cancelled
Details
continuous build / build (cmake, gcc, gfortran, ubuntu-24.04-arm) (push) Has been cancelled
Details
continuous build / build (cmake, gcc, gfortran, ubuntu-latest) (push) Has been cancelled
Details
continuous build / build (make, clang, flang, ubuntu-latest) (push) Has been cancelled
Details
continuous build / build (make, clang, gfortran, macos-latest) (push) Has been cancelled
Details
continuous build / build (make, clang, gfortran, ubuntu-24.04-arm) (push) Has been cancelled
Details
continuous build / build (make, clang, gfortran, ubuntu-latest) (push) Has been cancelled
Details
continuous build / build (make, clang-21, flang, ubuntu-latest) (push) Has been cancelled
Details
continuous build / build (make, clang-21, gfortran, ubuntu-24.04-arm) (push) Has been cancelled
Details
continuous build / build (make, clang-21, gfortran, ubuntu-latest) (push) Has been cancelled
Details
continuous build / build (make, gcc, flang, ubuntu-latest) (push) Has been cancelled
Details
continuous build / build (make, gcc, gfortran, ubuntu-24.04-arm) (push) Has been cancelled
Details
continuous build / build (make, gcc, gfortran, ubuntu-latest) (push) Has been cancelled
Details
continuous build / msys2 (None, fc, int32, UCRT64, mingw-w64-ucrt-x86_64) (push) Has been cancelled
Details
continuous build / msys2 (Release, fc, int32, CLANG64, mingw-w64-clang-x86_64) (push) Has been cancelled
Details
continuous build / msys2 (Release, fc, int32, MINGW32, mingw-w64-i686) (push) Has been cancelled
Details
continuous build / msys2 (Release, fc, int32, UCRT64, mingw-w64-ucrt-x86_64) (push) Has been cancelled
Details
continuous build / msys2 (Release, fc, int64, -DBINARY=64 -DINTERFACE64=1, CLANG64, mingw-w64-clang-x86_64) (push) Has been cancelled
Details
continuous build / msys2 (Release, fc, int64, -DBINARY=64 -DINTERFACE64=1, UCRT64, mingw-w64-ucrt-x86_64) (push) Has been cancelled
Details
continuous build / cross_build (DYNAMIC_ARCH=1 TARGET=GENERIC, mips64el, mips64el-linux-gnuabi64) (push) Has been cancelled
Details
continuous build / cross_build (TARGET=EV4, alpha, alpha-linux-gnu) (push) Has been cancelled
Details
continuous build / cross_build (TARGET=MIPS1004K, mipsel, mipsel-linux-gnu) (push) Has been cancelled
Details
continuous build / cross_build (TARGET=RISCV64_GENERIC, riscv64, riscv64-linux-gnu) (push) Has been cancelled
Details
continuous build / neoverse_build (push) Has been cancelled
Details
harmonyos / build (push) Has been cancelled
Details
loongarch64 qemu test / TEST (NO_SHARED=1 DYNAMIC_ARCH=1 TARGET=GENERIC, DYNAMIC_ARCH, loongarch64-linux-gnu) (push) Has been cancelled
Details
loongarch64 qemu test / TEST (NO_SHARED=1 DYNAMIC_ARCH=1 TARGET=LA264, LA264, loongarch64-linux-gnu) (push) Has been cancelled
Details
loongarch64 qemu test / TEST (NO_SHARED=1 DYNAMIC_ARCH=1 TARGET=LA464, LA464, loongarch64-linux-gnu) (push) Has been cancelled
Details
loongarch64 qemu test / TEST (NO_SHARED=1 DYNAMIC_ARCH=1 TARGET=LA64_GENERIC, LA64_GENERIC, loongarch64-linux-gnu) (push) Has been cancelled
Details
loongarch64 qemu test / TEST (NO_SHARED=1 DYNAMIC_ARCH=1 TARGET=LOONGSON2K1000, LOONGSON2K1000, loongarch64-linux-gnu) (push) Has been cancelled
Details
loongarch64 qemu test / TEST (NO_SHARED=1 DYNAMIC_ARCH=1 TARGET=LOONGSON3R5, LOONGSON3R5, loongarch64-linux-gnu) (push) Has been cancelled
Details
loongarch64 qemu test / TEST (NO_SHARED=1 DYNAMIC_ARCH=1 TARGET=LOONGSONGENERIC, LOONGSONGENERIC, loongarch64-linux-gnu) (push) Has been cancelled
Details
loongarch64 clang qemu test / TEST (NO_SHARED=1 DYNAMIC_ARCH=1 TARGET=GENERIC, DYNAMIC_ARCH) (push) Has been cancelled
Details
loongarch64 clang qemu test / TEST (NO_SHARED=1 DYNAMIC_ARCH=1 TARGET=LA264, LA264) (push) Has been cancelled
Details
loongarch64 clang qemu test / TEST (NO_SHARED=1 DYNAMIC_ARCH=1 TARGET=LA464, LA464) (push) Has been cancelled
Details
loongarch64 clang qemu test / TEST (NO_SHARED=1 DYNAMIC_ARCH=1 TARGET=LA64_GENERIC, LA64_GENERIC) (push) Has been cancelled
Details
loongarch64 clang qemu test / TEST (NO_SHARED=1 DYNAMIC_ARCH=1 TARGET=LOONGSON2K1000, LOONGSON2K1000) (push) Has been cancelled
Details
loongarch64 clang qemu test / TEST (NO_SHARED=1 DYNAMIC_ARCH=1 TARGET=LOONGSON3R5, LOONGSON3R5) (push) Has been cancelled
Details
loongarch64 clang qemu test / TEST (NO_SHARED=1 DYNAMIC_ARCH=1 TARGET=LOONGSONGENERIC, LOONGSONGENERIC) (push) Has been cancelled
Details
mips64 qemu test / TEST (NO_SHARED=1 TARGET=I6400, I6400, mipsisa64r6el-linux-gnuabi64) (push) Has been cancelled
Details
mips64 qemu test / TEST (NO_SHARED=1 TARGET=I6500, I6500, mipsisa64r6el-linux-gnuabi64) (push) Has been cancelled
Details
mips64 qemu test / TEST (NO_SHARED=1 TARGET=MIPS64_GENERIC, MIPS64_GENERIC, mips64el-linux-gnuabi64) (push) Has been cancelled
Details
mips64 qemu test / TEST (NO_SHARED=1 TARGET=P6600, P6600, mipsisa64r6el-linux-gnuabi64) (push) Has been cancelled
Details
mips64 qemu test / TEST (NO_SHARED=1 TARGET=SICORTEX, SICORTEX, mips64el-linux-gnuabi64) (push) Has been cancelled
Details
riscv64 zvl256b qemu test / TEST (TARGET=RISCV64_GENERIC BINARY=64 ARCH=riscv64 DYNAMIC_ARCH=1, rv64,g=true,c=true,v=true,vext_spec=v1.0,vlen=256,elen=64, DYNAMIC_ARCH=1) (push) Has been cancelled
Details
riscv64 zvl256b qemu test / TEST (TARGET=RISCV64_ZVL128B BINARY=64 ARCH=riscv64, rv64,g=true,c=true,v=true,vext_spec=v1.0,vlen=128,elen=64, RISCV64_ZVL128B) (push) Has been cancelled
Details
riscv64 zvl256b qemu test / TEST (TARGET=RISCV64_ZVL256B BINARY=64 ARCH=riscv64 BUILD_BFLOAT16=1 BUILD_HFLOAT16=1, rv64,g=true,c=true,v=true,vext_spec=v1.0,vlen=256,elen=64,zfh=true,zvfh=true,zvfbfwma=true, RISCV64_ZVL256B) (push) Has been cancelled
Details
Windows ARM64 CI / build (push) Has been cancelled
Details
Nightly-Homebrew-Build / build-OpenBLAS-with-Homebrew (push) Has been cancelled
Details

Browse Source 
Fix workspace size in ?TGSEN (Reference-LAPACK PR 774)
This commit is contained in:
Martin Kroeker
2026-04-01 08:52:37 +02:00
committed by GitHub
parent 429d23f420 cc74393520
commit d27e98c97a
4 changed files with 98 additions and 60 deletions
Download Patch File Download Diff File Expand all files Collapse all files

37
lapack-netlib/SRC/ctgsen.f
View File

@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download CTGSEN + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ctgsen.f">
*> [TGZ]</a>
@@ -13,7 +12,6 @@
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ctgsen.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
@@ -242,7 +240,7 @@
*> \verbatim
*> LWORK is INTEGER
*> The dimension of the array WORK. LWORK >= 1
*> If IJOB = 1, 2 or 4, LWORK >= 2*M*(N-M)
*> If IJOB = 1, 2 or 4, LWORK >= 2*M*(N-M) + 1
*> If IJOB = 3 or 5, LWORK >= 4*M*(N-M)
*>
*> If LWORK = -1, then a workspace query is assumed; the routine
@@ -427,9 +425,11 @@
*> 1996.
*>
* =====================================================================
SUBROUTINE CTGSEN( IJOB, WANTQ, WANTZ, SELECT, N, A, LDA, B, LDB,
SUBROUTINE CTGSEN( IJOB, WANTQ, WANTZ, SELECT, N, A, LDA, B,
$ LDB,
$ ALPHA, BETA, Q, LDQ, Z, LDZ, M, PL, PR, DIF,
$ WORK, LWORK, IWORK, LIWORK, INFO )
IMPLICIT NONE
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
@@ -473,7 +473,8 @@
* ..
* .. External Subroutines ..
REAL SLAMCH
EXTERNAL CLACN2, CLACPY, CLASSQ, CSCAL, CTGEXC, CTGSYL,
EXTERNAL CLACN2, CLACPY, CLASSQ, CSCAL, CTGEXC,
$ CTGSYL,
$ SLAMCH, XERBLA
* ..
* .. Intrinsic Functions ..
@@ -531,7 +532,7 @@
END IF
*
IF( IJOB.EQ.1 .OR. IJOB.EQ.2 .OR. IJOB.EQ.4 ) THEN
LWMIN = MAX( 1, 2*M*(N-M) )
LWMIN = MAX( 1, 2*M*(N-M) + 1 )
LIWMIN = MAX( 1, N+2 )
ELSE IF( IJOB.EQ.3 .OR. IJOB.EQ.5 ) THEN
LWMIN = MAX( 1, 4*M*(N-M) )
@@ -593,7 +594,8 @@
* and Z that will swap adjacent diagonal blocks in (A, B).
*
IF( K.NE.KS )
$ CALL CTGEXC( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z,
$ CALL CTGEXC( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ,
$ Z,
$ LDZ, K, KS, IERR )
*
IF( IERR.GT.0 ) THEN
@@ -623,7 +625,8 @@
N2 = N - M
I = N1 + 1
CALL CLACPY( 'Full', N1, N2, A( 1, I ), LDA, WORK, N1 )
CALL CLACPY( 'Full', N1, N2, B( 1, I ), LDB, WORK( N1*N2+1 ),
CALL CLACPY( 'Full', N1, N2, B( 1, I ), LDB,
$ WORK( N1*N2+1 ),
$ N1 )
IJB = 0
CALL CTGSYL( 'N', IJB, N1, N2, A, LDA, A( I, I ), LDA, WORK,
@@ -665,14 +668,16 @@
*
* Frobenius norm-based Difu estimate.
*
CALL CTGSYL( 'N', IJB, N1, N2, A, LDA, A( I, I ), LDA, WORK,
CALL CTGSYL( 'N', IJB, N1, N2, A, LDA, A( I, I ), LDA,
$ WORK,
$ N1, B, LDB, B( I, I ), LDB, WORK( N1*N2+1 ),
$ N1, DSCALE, DIF( 1 ), WORK( N1*N2*2+1 ),
$ LWORK-2*N1*N2, IWORK, IERR )
*
* Frobenius norm-based Difl estimate.
*
CALL CTGSYL( 'N', IJB, N2, N1, A( I, I ), LDA, A, LDA, WORK,
CALL CTGSYL( 'N', IJB, N2, N1, A( I, I ), LDA, A, LDA,
$ WORK,
$ N2, B( I, I ), LDB, B, LDB, WORK( N1*N2+1 ),
$ N2, DSCALE, DIF( 2 ), WORK( N1*N2*2+1 ),
$ LWORK-2*N1*N2, IWORK, IERR )
@@ -700,7 +705,8 @@
*
* Solve generalized Sylvester equation
*
CALL CTGSYL( 'N', IJB, N1, N2, A, LDA, A( I, I ), LDA,
CALL CTGSYL( 'N', IJB, N1, N2, A, LDA, A( I, I ),
$ LDA,
$ WORK, N1, B, LDB, B( I, I ), LDB,
$ WORK( N1*N2+1 ), N1, DSCALE, DIF( 1 ),
$ WORK( N1*N2*2+1 ), LWORK-2*N1*N2, IWORK,
@@ -709,7 +715,8 @@
*
* Solve the transposed variant.
*
CALL CTGSYL( 'C', IJB, N1, N2, A, LDA, A( I, I ), LDA,
CALL CTGSYL( 'C', IJB, N1, N2, A, LDA, A( I, I ),
$ LDA,
$ WORK, N1, B, LDB, B( I, I ), LDB,
$ WORK( N1*N2+1 ), N1, DSCALE, DIF( 1 ),
$ WORK( N1*N2*2+1 ), LWORK-2*N1*N2, IWORK,
@@ -729,7 +736,8 @@
*
* Solve generalized Sylvester equation
*
CALL CTGSYL( 'N', IJB, N2, N1, A( I, I ), LDA, A, LDA,
CALL CTGSYL( 'N', IJB, N2, N1, A( I, I ), LDA, A,
$ LDA,
$ WORK, N2, B( I, I ), LDB, B, LDB,
$ WORK( N1*N2+1 ), N2, DSCALE, DIF( 2 ),
$ WORK( N1*N2*2+1 ), LWORK-2*N1*N2, IWORK,
@@ -738,7 +746,8 @@
*
* Solve the transposed variant.
*
CALL CTGSYL( 'C', IJB, N2, N1, A( I, I ), LDA, A, LDA,
CALL CTGSYL( 'C', IJB, N2, N1, A( I, I ), LDA, A,
$ LDA,
$ WORK, N2, B, LDB, B( I, I ), LDB,
$ WORK( N1*N2+1 ), N2, DSCALE, DIF( 2 ),
$ WORK( N1*N2*2+1 ), LWORK-2*N1*N2, IWORK,

42
lapack-netlib/SRC/dtgsen.f
View File

@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DTGSEN + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dtgsen.f">
*> [TGZ]</a>
@@ -13,7 +12,6 @@
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dtgsen.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
@@ -256,7 +254,7 @@
*> \verbatim
*> LWORK is INTEGER
*> The dimension of the array WORK. LWORK >= 4*N+16.
*> If IJOB = 1, 2 or 4, LWORK >= MAX(4*N+16, 2*M*(N-M)).
*> If IJOB = 1, 2 or 4, LWORK >= MAX(4*N+16, 2*M*(N-M) + 1).
*> If IJOB = 3 or 5, LWORK >= MAX(4*N+16, 4*M*(N-M)).
*>
*> If LWORK = -1, then a workspace query is assumed; the routine
@@ -304,7 +302,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup doubleOTHERcomputational
*> \ingroup tgsen
*
*> \par Further Details:
* =====================
@@ -445,9 +443,11 @@
*> \endverbatim
*>
* =====================================================================
SUBROUTINE DTGSEN( IJOB, WANTQ, WANTZ, SELECT, N, A, LDA, B, LDB,
SUBROUTINE DTGSEN( IJOB, WANTQ, WANTZ, SELECT, N, A, LDA, B,
$ LDB,
$ ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDZ, M, PL,
$ PR, DIF, WORK, LWORK, IWORK, LIWORK, INFO )
IMPLICIT NONE
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
@@ -486,7 +486,8 @@
INTEGER ISAVE( 3 )
* ..
* .. External Subroutines ..
EXTERNAL DLACN2, DLACPY, DLAG2, DLASSQ, DTGEXC, DTGSYL,
EXTERNAL DLACN2, DLACPY, DLAG2, DLASSQ, DTGEXC,
$ DTGSYL,
$ XERBLA
* ..
* .. External Functions ..
@@ -561,7 +562,7 @@
END IF
*
IF( IJOB.EQ.1 .OR. IJOB.EQ.2 .OR. IJOB.EQ.4 ) THEN
LWMIN = MAX( 1, 4*N+16, 2*M*( N-M ) )
LWMIN = MAX( 1, 4*N+16, 2*M*( N-M ) + 1 )
LIWMIN = MAX( 1, N+6 )
ELSE IF( IJOB.EQ.3 .OR. IJOB.EQ.5 ) THEN
LWMIN = MAX( 1, 4*N+16, 4*M*( N-M ) )
@@ -634,7 +635,8 @@
*
KK = K
IF( K.NE.KS )
$ CALL DTGEXC( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ,
$ CALL DTGEXC( WANTQ, WANTZ, N, A, LDA, B, LDB, Q,
$ LDQ,
$ Z, LDZ, KK, KS, WORK, LWORK, IERR )
*
IF( IERR.GT.0 ) THEN
@@ -668,7 +670,8 @@
I = N1 + 1
IJB = 0
CALL DLACPY( 'Full', N1, N2, A( 1, I ), LDA, WORK, N1 )
CALL DLACPY( 'Full', N1, N2, B( 1, I ), LDB, WORK( N1*N2+1 ),
CALL DLACPY( 'Full', N1, N2, B( 1, I ), LDB,
$ WORK( N1*N2+1 ),
$ N1 )
CALL DTGSYL( 'N', IJB, N1, N2, A, LDA, A( I, I ), LDA, WORK,
$ N1, B, LDB, B( I, I ), LDB, WORK( N1*N2+1 ), N1,
@@ -710,14 +713,16 @@
*
* Frobenius norm-based Difu-estimate.
*
CALL DTGSYL( 'N', IJB, N1, N2, A, LDA, A( I, I ), LDA, WORK,
CALL DTGSYL( 'N', IJB, N1, N2, A, LDA, A( I, I ), LDA,
$ WORK,
$ N1, B, LDB, B( I, I ), LDB, WORK( N1*N2+1 ),
$ N1, DSCALE, DIF( 1 ), WORK( 2*N1*N2+1 ),
$ LWORK-2*N1*N2, IWORK, IERR )
*
* Frobenius norm-based Difl-estimate.
*
CALL DTGSYL( 'N', IJB, N2, N1, A( I, I ), LDA, A, LDA, WORK,
CALL DTGSYL( 'N', IJB, N2, N1, A( I, I ), LDA, A, LDA,
$ WORK,
$ N2, B( I, I ), LDB, B, LDB, WORK( N1*N2+1 ),
$ N2, DSCALE, DIF( 2 ), WORK( 2*N1*N2+1 ),
$ LWORK-2*N1*N2, IWORK, IERR )
@@ -746,7 +751,8 @@
*
* Solve generalized Sylvester equation.
*
CALL DTGSYL( 'N', IJB, N1, N2, A, LDA, A( I, I ), LDA,
CALL DTGSYL( 'N', IJB, N1, N2, A, LDA, A( I, I ),
$ LDA,
$ WORK, N1, B, LDB, B( I, I ), LDB,
$ WORK( N1*N2+1 ), N1, DSCALE, DIF( 1 ),
$ WORK( 2*N1*N2+1 ), LWORK-2*N1*N2, IWORK,
@@ -755,7 +761,8 @@
*
* Solve the transposed variant.
*
CALL DTGSYL( 'T', IJB, N1, N2, A, LDA, A( I, I ), LDA,
CALL DTGSYL( 'T', IJB, N1, N2, A, LDA, A( I, I ),
$ LDA,
$ WORK, N1, B, LDB, B( I, I ), LDB,
$ WORK( N1*N2+1 ), N1, DSCALE, DIF( 1 ),
$ WORK( 2*N1*N2+1 ), LWORK-2*N1*N2, IWORK,
@@ -775,7 +782,8 @@
*
* Solve generalized Sylvester equation.
*
CALL DTGSYL( 'N', IJB, N2, N1, A( I, I ), LDA, A, LDA,
CALL DTGSYL( 'N', IJB, N2, N1, A( I, I ), LDA, A,
$ LDA,
$ WORK, N2, B( I, I ), LDB, B, LDB,
$ WORK( N1*N2+1 ), N2, DSCALE, DIF( 2 ),
$ WORK( 2*N1*N2+1 ), LWORK-2*N1*N2, IWORK,
@@ -784,7 +792,8 @@
*
* Solve the transposed variant.
*
CALL DTGSYL( 'T', IJB, N2, N1, A( I, I ), LDA, A, LDA,
CALL DTGSYL( 'T', IJB, N2, N1, A( I, I ), LDA, A,
$ LDA,
$ WORK, N2, B( I, I ), LDB, B, LDB,
$ WORK( N1*N2+1 ), N2, DSCALE, DIF( 2 ),
$ WORK( 2*N1*N2+1 ), LWORK-2*N1*N2, IWORK,
@@ -826,7 +835,8 @@
WORK( 6 ) = B( K+1, K )
WORK( 7 ) = B( K, K+1 )
WORK( 8 ) = B( K+1, K+1 )
CALL DLAG2( WORK, 2, WORK( 5 ), 2, SMLNUM*EPS, BETA( K ),
CALL DLAG2( WORK, 2, WORK( 5 ), 2, SMLNUM*EPS,
$ BETA( K ),
$ BETA( K+1 ), ALPHAR( K ), ALPHAR( K+1 ),
$ ALPHAI( K ) )
ALPHAI( K+1 ) = -ALPHAI( K )

40
lapack-netlib/SRC/stgsen.f
View File

@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download STGSEN + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/stgsen.f">
*> [TGZ]</a>
@@ -13,7 +12,6 @@
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/stgsen.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
@@ -256,7 +254,7 @@
*> \verbatim
*> LWORK is INTEGER
*> The dimension of the array WORK. LWORK >= 4*N+16.
*> If IJOB = 1, 2 or 4, LWORK >= MAX(4*N+16, 2*M*(N-M)).
*> If IJOB = 1, 2 or 4, LWORK >= MAX(4*N+16, 2*M*(N-M) + 1).
*> If IJOB = 3 or 5, LWORK >= MAX(4*N+16, 4*M*(N-M)).
*>
*> If LWORK = -1, then a workspace query is assumed; the routine
@@ -445,9 +443,11 @@
*> \endverbatim
*>
* =====================================================================
SUBROUTINE STGSEN( IJOB, WANTQ, WANTZ, SELECT, N, A, LDA, B, LDB,
SUBROUTINE STGSEN( IJOB, WANTQ, WANTZ, SELECT, N, A, LDA, B,
$ LDB,
$ ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDZ, M, PL,
$ PR, DIF, WORK, LWORK, IWORK, LIWORK, INFO )
IMPLICIT NONE
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
@@ -486,7 +486,8 @@
INTEGER ISAVE( 3 )
* ..
* .. External Subroutines ..
EXTERNAL SLACN2, SLACPY, SLAG2, SLASSQ, STGEXC, STGSYL,
EXTERNAL SLACN2, SLACPY, SLAG2, SLASSQ, STGEXC,
$ STGSYL,
$ XERBLA
* ..
* .. External Functions ..
@@ -561,7 +562,7 @@
END IF
*
IF( IJOB.EQ.1 .OR. IJOB.EQ.2 .OR. IJOB.EQ.4 ) THEN
LWMIN = MAX( 1, 4*N+16, 2*M*(N-M) )
LWMIN = MAX( 1, 4*N+16, 2*M*(N-M) + 1 )
LIWMIN = MAX( 1, N+6 )
ELSE IF( IJOB.EQ.3 .OR. IJOB.EQ.5 ) THEN
LWMIN = MAX( 1, 4*N+16, 4*M*(N-M) )
@@ -634,7 +635,8 @@
*
KK = K
IF( K.NE.KS )
$ CALL STGEXC( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ,
$ CALL STGEXC( WANTQ, WANTZ, N, A, LDA, B, LDB, Q,
$ LDQ,
$ Z, LDZ, KK, KS, WORK, LWORK, IERR )
*
IF( IERR.GT.0 ) THEN
@@ -668,7 +670,8 @@
I = N1 + 1
IJB = 0
CALL SLACPY( 'Full', N1, N2, A( 1, I ), LDA, WORK, N1 )
CALL SLACPY( 'Full', N1, N2, B( 1, I ), LDB, WORK( N1*N2+1 ),
CALL SLACPY( 'Full', N1, N2, B( 1, I ), LDB,
$ WORK( N1*N2+1 ),
$ N1 )
CALL STGSYL( 'N', IJB, N1, N2, A, LDA, A( I, I ), LDA, WORK,
$ N1, B, LDB, B( I, I ), LDB, WORK( N1*N2+1 ), N1,
@@ -710,14 +713,16 @@
*
* Frobenius norm-based Difu-estimate.
*
CALL STGSYL( 'N', IJB, N1, N2, A, LDA, A( I, I ), LDA, WORK,
CALL STGSYL( 'N', IJB, N1, N2, A, LDA, A( I, I ), LDA,
$ WORK,
$ N1, B, LDB, B( I, I ), LDB, WORK( N1*N2+1 ),
$ N1, DSCALE, DIF( 1 ), WORK( 2*N1*N2+1 ),
$ LWORK-2*N1*N2, IWORK, IERR )
*
* Frobenius norm-based Difl-estimate.
*
CALL STGSYL( 'N', IJB, N2, N1, A( I, I ), LDA, A, LDA, WORK,
CALL STGSYL( 'N', IJB, N2, N1, A( I, I ), LDA, A, LDA,
$ WORK,
$ N2, B( I, I ), LDB, B, LDB, WORK( N1*N2+1 ),
$ N2, DSCALE, DIF( 2 ), WORK( 2*N1*N2+1 ),
$ LWORK-2*N1*N2, IWORK, IERR )
@@ -746,7 +751,8 @@
*
* Solve generalized Sylvester equation.
*
CALL STGSYL( 'N', IJB, N1, N2, A, LDA, A( I, I ), LDA,
CALL STGSYL( 'N', IJB, N1, N2, A, LDA, A( I, I ),
$ LDA,
$ WORK, N1, B, LDB, B( I, I ), LDB,
$ WORK( N1*N2+1 ), N1, DSCALE, DIF( 1 ),
$ WORK( 2*N1*N2+1 ), LWORK-2*N1*N2, IWORK,
@@ -755,7 +761,8 @@
*
* Solve the transposed variant.
*
CALL STGSYL( 'T', IJB, N1, N2, A, LDA, A( I, I ), LDA,
CALL STGSYL( 'T', IJB, N1, N2, A, LDA, A( I, I ),
$ LDA,
$ WORK, N1, B, LDB, B( I, I ), LDB,
$ WORK( N1*N2+1 ), N1, DSCALE, DIF( 1 ),
$ WORK( 2*N1*N2+1 ), LWORK-2*N1*N2, IWORK,
@@ -775,7 +782,8 @@
*
* Solve generalized Sylvester equation.
*
CALL STGSYL( 'N', IJB, N2, N1, A( I, I ), LDA, A, LDA,
CALL STGSYL( 'N', IJB, N2, N1, A( I, I ), LDA, A,
$ LDA,
$ WORK, N2, B( I, I ), LDB, B, LDB,
$ WORK( N1*N2+1 ), N2, DSCALE, DIF( 2 ),
$ WORK( 2*N1*N2+1 ), LWORK-2*N1*N2, IWORK,
@@ -784,7 +792,8 @@
*
* Solve the transposed variant.
*
CALL STGSYL( 'T', IJB, N2, N1, A( I, I ), LDA, A, LDA,
CALL STGSYL( 'T', IJB, N2, N1, A( I, I ), LDA, A,
$ LDA,
$ WORK, N2, B( I, I ), LDB, B, LDB,
$ WORK( N1*N2+1 ), N2, DSCALE, DIF( 2 ),
$ WORK( 2*N1*N2+1 ), LWORK-2*N1*N2, IWORK,
@@ -826,7 +835,8 @@
WORK( 6 ) = B( K+1, K )
WORK( 7 ) = B( K, K+1 )
WORK( 8 ) = B( K+1, K+1 )
CALL SLAG2( WORK, 2, WORK( 5 ), 2, SMLNUM*EPS, BETA( K ),
CALL SLAG2( WORK, 2, WORK( 5 ), 2, SMLNUM*EPS,
$ BETA( K ),
$ BETA( K+1 ), ALPHAR( K ), ALPHAR( K+1 ),
$ ALPHAI( K ) )
ALPHAI( K+1 ) = -ALPHAI( K )

39
lapack-netlib/SRC/ztgsen.f
View File

@@ -5,7 +5,6 @@
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZTGSEN + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ztgsen.f">
*> [TGZ]</a>
@@ -13,7 +12,6 @@
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ztgsen.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
@@ -242,7 +240,7 @@
*> \verbatim
*> LWORK is INTEGER
*> The dimension of the array WORK. LWORK >= 1
*> If IJOB = 1, 2 or 4, LWORK >= 2*M*(N-M)
*> If IJOB = 1, 2 or 4, LWORK >= 2*M*(N-M) + 1
*> If IJOB = 3 or 5, LWORK >= 4*M*(N-M)
*>
*> If LWORK = -1, then a workspace query is assumed; the routine
@@ -290,7 +288,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup complex16OTHERcomputational
*> \ingroup tgsen
*
*> \par Further Details:
* =====================
@@ -427,9 +425,11 @@
*> 1996.
*>
* =====================================================================
SUBROUTINE ZTGSEN( IJOB, WANTQ, WANTZ, SELECT, N, A, LDA, B, LDB,
SUBROUTINE ZTGSEN( IJOB, WANTQ, WANTZ, SELECT, N, A, LDA, B,
$ LDB,
$ ALPHA, BETA, Q, LDQ, Z, LDZ, M, PL, PR, DIF,
$ WORK, LWORK, IWORK, LIWORK, INFO )
IMPLICIT NONE
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
@@ -468,7 +468,8 @@
INTEGER ISAVE( 3 )
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZLACN2, ZLACPY, ZLASSQ, ZSCAL, ZTGEXC,
EXTERNAL XERBLA, ZLACN2, ZLACPY, ZLASSQ, ZSCAL,
$ ZTGEXC,
$ ZTGSYL
* ..
* .. Intrinsic Functions ..
@@ -530,7 +531,7 @@
END IF
*
IF( IJOB.EQ.1 .OR. IJOB.EQ.2 .OR. IJOB.EQ.4 ) THEN
LWMIN = MAX( 1, 2*M*( N-M ) )
LWMIN = MAX( 1, 2*M*( N-M ) + 1 )
LIWMIN = MAX( 1, N+2 )
ELSE IF( IJOB.EQ.3 .OR. IJOB.EQ.5 ) THEN
LWMIN = MAX( 1, 4*M*( N-M ) )
@@ -592,7 +593,8 @@
* and Z that will swap adjacent diagonal blocks in (A, B).
*
IF( K.NE.KS )
$ CALL ZTGEXC( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z,
$ CALL ZTGEXC( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ,
$ Z,
$ LDZ, K, KS, IERR )
*
IF( IERR.GT.0 ) THEN
@@ -622,7 +624,8 @@
N2 = N - M
I = N1 + 1
CALL ZLACPY( 'Full', N1, N2, A( 1, I ), LDA, WORK, N1 )
CALL ZLACPY( 'Full', N1, N2, B( 1, I ), LDB, WORK( N1*N2+1 ),
CALL ZLACPY( 'Full', N1, N2, B( 1, I ), LDB,
$ WORK( N1*N2+1 ),
$ N1 )
IJB = 0
CALL ZTGSYL( 'N', IJB, N1, N2, A, LDA, A( I, I ), LDA, WORK,
@@ -664,14 +667,16 @@
*
* Frobenius norm-based Difu estimate.
*
CALL ZTGSYL( 'N', IJB, N1, N2, A, LDA, A( I, I ), LDA, WORK,
CALL ZTGSYL( 'N', IJB, N1, N2, A, LDA, A( I, I ), LDA,
$ WORK,
$ N1, B, LDB, B( I, I ), LDB, WORK( N1*N2+1 ),
$ N1, DSCALE, DIF( 1 ), WORK( N1*N2*2+1 ),
$ LWORK-2*N1*N2, IWORK, IERR )
*
* Frobenius norm-based Difl estimate.
*
CALL ZTGSYL( 'N', IJB, N2, N1, A( I, I ), LDA, A, LDA, WORK,
CALL ZTGSYL( 'N', IJB, N2, N1, A( I, I ), LDA, A, LDA,
$ WORK,
$ N2, B( I, I ), LDB, B, LDB, WORK( N1*N2+1 ),
$ N2, DSCALE, DIF( 2 ), WORK( N1*N2*2+1 ),
$ LWORK-2*N1*N2, IWORK, IERR )
@@ -699,7 +704,8 @@
*
* Solve generalized Sylvester equation
*
CALL ZTGSYL( 'N', IJB, N1, N2, A, LDA, A( I, I ), LDA,
CALL ZTGSYL( 'N', IJB, N1, N2, A, LDA, A( I, I ),
$ LDA,
$ WORK, N1, B, LDB, B( I, I ), LDB,
$ WORK( N1*N2+1 ), N1, DSCALE, DIF( 1 ),
$ WORK( N1*N2*2+1 ), LWORK-2*N1*N2, IWORK,
@@ -708,7 +714,8 @@
*
* Solve the transposed variant.
*
CALL ZTGSYL( 'C', IJB, N1, N2, A, LDA, A( I, I ), LDA,
CALL ZTGSYL( 'C', IJB, N1, N2, A, LDA, A( I, I ),
$ LDA,
$ WORK, N1, B, LDB, B( I, I ), LDB,
$ WORK( N1*N2+1 ), N1, DSCALE, DIF( 1 ),
$ WORK( N1*N2*2+1 ), LWORK-2*N1*N2, IWORK,
@@ -728,7 +735,8 @@
*
* Solve generalized Sylvester equation
*
CALL ZTGSYL( 'N', IJB, N2, N1, A( I, I ), LDA, A, LDA,
CALL ZTGSYL( 'N', IJB, N2, N1, A( I, I ), LDA, A,
$ LDA,
$ WORK, N2, B( I, I ), LDB, B, LDB,
$ WORK( N1*N2+1 ), N2, DSCALE, DIF( 2 ),
$ WORK( N1*N2*2+1 ), LWORK-2*N1*N2, IWORK,
@@ -737,7 +745,8 @@
*
* Solve the transposed variant.
*
CALL ZTGSYL( 'C', IJB, N2, N1, A( I, I ), LDA, A, LDA,
CALL ZTGSYL( 'C', IJB, N2, N1, A( I, I ), LDA, A,
$ LDA,
$ WORK, N2, B, LDB, B( I, I ), LDB,
$ WORK( N1*N2+1 ), N2, DSCALE, DIF( 2 ),
$ WORK( N1*N2*2+1 ), LWORK-2*N1*N2, IWORK,