added lapack 3.7.0 with latest patches from git
This commit is contained in:
Werner Saar
297
lapack-netlib/SRC/cgbtrs.f
Normal file
297
lapack-netlib/SRC/cgbtrs.f
Normal file
@@ -0,0 +1,297 @@
|
||||
*> \brief \b CGBTRS
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
*> \htmlonly
|
||||
*> Download CGBTRS + dependencies
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/cgbtrs.f">
|
||||
*> [TGZ]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/cgbtrs.f">
|
||||
*> [ZIP]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/cgbtrs.f">
|
||||
*> [TXT]</a>
|
||||
*> \endhtmlonly
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE CGBTRS( TRANS, N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB,
|
||||
* INFO )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* CHARACTER TRANS
|
||||
* INTEGER INFO, KL, KU, LDAB, LDB, N, NRHS
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* INTEGER IPIV( * )
|
||||
* COMPLEX AB( LDAB, * ), B( LDB, * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> CGBTRS solves a system of linear equations
|
||||
*> A * X = B, A**T * X = B, or A**H * X = B
|
||||
*> with a general band matrix A using the LU factorization computed
|
||||
*> by CGBTRF.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] TRANS
|
||||
*> \verbatim
|
||||
*> TRANS is CHARACTER*1
|
||||
*> Specifies the form of the system of equations.
|
||||
*> = 'N': A * X = B (No transpose)
|
||||
*> = 'T': A**T * X = B (Transpose)
|
||||
*> = 'C': A**H * X = B (Conjugate transpose)
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> The order of the matrix A. N >= 0.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] KL
|
||||
*> \verbatim
|
||||
*> KL is INTEGER
|
||||
*> The number of subdiagonals within the band of A. KL >= 0.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] KU
|
||||
*> \verbatim
|
||||
*> KU is INTEGER
|
||||
*> The number of superdiagonals within the band of A. KU >= 0.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] NRHS
|
||||
*> \verbatim
|
||||
*> NRHS is INTEGER
|
||||
*> The number of right hand sides, i.e., the number of columns
|
||||
*> of the matrix B. NRHS >= 0.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] AB
|
||||
*> \verbatim
|
||||
*> AB is COMPLEX array, dimension (LDAB,N)
|
||||
*> Details of the LU factorization of the band matrix A, as
|
||||
*> computed by CGBTRF. U is stored as an upper triangular band
|
||||
*> matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and
|
||||
*> the multipliers used during the factorization are stored in
|
||||
*> rows KL+KU+2 to 2*KL+KU+1.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDAB
|
||||
*> \verbatim
|
||||
*> LDAB is INTEGER
|
||||
*> The leading dimension of the array AB. LDAB >= 2*KL+KU+1.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] IPIV
|
||||
*> \verbatim
|
||||
*> IPIV is INTEGER array, dimension (N)
|
||||
*> The pivot indices; for 1 <= i <= N, row i of the matrix was
|
||||
*> interchanged with row IPIV(i).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] B
|
||||
*> \verbatim
|
||||
*> B is COMPLEX array, dimension (LDB,NRHS)
|
||||
*> On entry, the right hand side matrix B.
|
||||
*> On exit, the solution matrix X.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDB
|
||||
*> \verbatim
|
||||
*> LDB is INTEGER
|
||||
*> The leading dimension of the array B. LDB >= max(1,N).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] INFO
|
||||
*> \verbatim
|
||||
*> INFO is INTEGER
|
||||
*> = 0: successful exit
|
||||
*> < 0: if INFO = -i, the i-th argument had an illegal value
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date December 2016
|
||||
*
|
||||
*> \ingroup complexGBcomputational
|
||||
*
|
||||
* =====================================================================
|
||||
SUBROUTINE CGBTRS( TRANS, N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB,
|
||||
$ INFO )
|
||||
*
|
||||
* -- LAPACK computational routine (version 3.7.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* December 2016
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
CHARACTER TRANS
|
||||
INTEGER INFO, KL, KU, LDAB, LDB, N, NRHS
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
INTEGER IPIV( * )
|
||||
COMPLEX AB( LDAB, * ), B( LDB, * )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
COMPLEX ONE
|
||||
PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ) )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
LOGICAL LNOTI, NOTRAN
|
||||
INTEGER I, J, KD, L, LM
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
EXTERNAL LSAME
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL CGEMV, CGERU, CLACGV, CSWAP, CTBSV, XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC MAX, MIN
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* Test the input parameters.
|
||||
*
|
||||
INFO = 0
|
||||
NOTRAN = LSAME( TRANS, 'N' )
|
||||
IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
|
||||
$ LSAME( TRANS, 'C' ) ) THEN
|
||||
INFO = -1
|
||||
ELSE IF( N.LT.0 ) THEN
|
||||
INFO = -2
|
||||
ELSE IF( KL.LT.0 ) THEN
|
||||
INFO = -3
|
||||
ELSE IF( KU.LT.0 ) THEN
|
||||
INFO = -4
|
||||
ELSE IF( NRHS.LT.0 ) THEN
|
||||
INFO = -5
|
||||
ELSE IF( LDAB.LT.( 2*KL+KU+1 ) ) THEN
|
||||
INFO = -7
|
||||
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
|
||||
INFO = -10
|
||||
END IF
|
||||
IF( INFO.NE.0 ) THEN
|
||||
CALL XERBLA( 'CGBTRS', -INFO )
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible
|
||||
*
|
||||
IF( N.EQ.0 .OR. NRHS.EQ.0 )
|
||||
$ RETURN
|
||||
*
|
||||
KD = KU + KL + 1
|
||||
LNOTI = KL.GT.0
|
||||
*
|
||||
IF( NOTRAN ) THEN
|
||||
*
|
||||
* Solve A*X = B.
|
||||
*
|
||||
* Solve L*X = B, overwriting B with X.
|
||||
*
|
||||
* L is represented as a product of permutations and unit lower
|
||||
* triangular matrices L = P(1) * L(1) * ... * P(n-1) * L(n-1),
|
||||
* where each transformation L(i) is a rank-one modification of
|
||||
* the identity matrix.
|
||||
*
|
||||
IF( LNOTI ) THEN
|
||||
DO 10 J = 1, N - 1
|
||||
LM = MIN( KL, N-J )
|
||||
L = IPIV( J )
|
||||
IF( L.NE.J )
|
||||
$ CALL CSWAP( NRHS, B( L, 1 ), LDB, B( J, 1 ), LDB )
|
||||
CALL CGERU( LM, NRHS, -ONE, AB( KD+1, J ), 1, B( J, 1 ),
|
||||
$ LDB, B( J+1, 1 ), LDB )
|
||||
10 CONTINUE
|
||||
END IF
|
||||
*
|
||||
DO 20 I = 1, NRHS
|
||||
*
|
||||
* Solve U*X = B, overwriting B with X.
|
||||
*
|
||||
CALL CTBSV( 'Upper', 'No transpose', 'Non-unit', N, KL+KU,
|
||||
$ AB, LDAB, B( 1, I ), 1 )
|
||||
20 CONTINUE
|
||||
*
|
||||
ELSE IF( LSAME( TRANS, 'T' ) ) THEN
|
||||
*
|
||||
* Solve A**T * X = B.
|
||||
*
|
||||
DO 30 I = 1, NRHS
|
||||
*
|
||||
* Solve U**T * X = B, overwriting B with X.
|
||||
*
|
||||
CALL CTBSV( 'Upper', 'Transpose', 'Non-unit', N, KL+KU, AB,
|
||||
$ LDAB, B( 1, I ), 1 )
|
||||
30 CONTINUE
|
||||
*
|
||||
* Solve L**T * X = B, overwriting B with X.
|
||||
*
|
||||
IF( LNOTI ) THEN
|
||||
DO 40 J = N - 1, 1, -1
|
||||
LM = MIN( KL, N-J )
|
||||
CALL CGEMV( 'Transpose', LM, NRHS, -ONE, B( J+1, 1 ),
|
||||
$ LDB, AB( KD+1, J ), 1, ONE, B( J, 1 ), LDB )
|
||||
L = IPIV( J )
|
||||
IF( L.NE.J )
|
||||
$ CALL CSWAP( NRHS, B( L, 1 ), LDB, B( J, 1 ), LDB )
|
||||
40 CONTINUE
|
||||
END IF
|
||||
*
|
||||
ELSE
|
||||
*
|
||||
* Solve A**H * X = B.
|
||||
*
|
||||
DO 50 I = 1, NRHS
|
||||
*
|
||||
* Solve U**H * X = B, overwriting B with X.
|
||||
*
|
||||
CALL CTBSV( 'Upper', 'Conjugate transpose', 'Non-unit', N,
|
||||
$ KL+KU, AB, LDAB, B( 1, I ), 1 )
|
||||
50 CONTINUE
|
||||
*
|
||||
* Solve L**H * X = B, overwriting B with X.
|
||||
*
|
||||
IF( LNOTI ) THEN
|
||||
DO 60 J = N - 1, 1, -1
|
||||
LM = MIN( KL, N-J )
|
||||
CALL CLACGV( NRHS, B( J, 1 ), LDB )
|
||||
CALL CGEMV( 'Conjugate transpose', LM, NRHS, -ONE,
|
||||
$ B( J+1, 1 ), LDB, AB( KD+1, J ), 1, ONE,
|
||||
$ B( J, 1 ), LDB )
|
||||
CALL CLACGV( NRHS, B( J, 1 ), LDB )
|
||||
L = IPIV( J )
|
||||
IF( L.NE.J )
|
||||
$ CALL CSWAP( NRHS, B( L, 1 ), LDB, B( J, 1 ), LDB )
|
||||
60 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
RETURN
|
||||
*
|
||||
* End of CGBTRS
|
||||
*
|
||||
END
|
||||
Reference in New Issue
Block a user