add missing BLAS/LAPACK functions used by LATTE to linalg lib
This commit is contained in:
Axel Kohlmeyer
58
lib/linalg/dcabs1.f
Normal file
58
lib/linalg/dcabs1.f
Normal file
@ -0,0 +1,58 @@
|
||||
*> \brief \b DCABS1
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* DOUBLE PRECISION FUNCTION DCABS1(Z)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* COMPLEX*16 Z
|
||||
* ..
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> DCABS1 computes absolute value of a double complex number
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup double_blas_level1
|
||||
*
|
||||
* =====================================================================
|
||||
DOUBLE PRECISION FUNCTION DCABS1(Z)
|
||||
*
|
||||
* -- Reference BLAS level1 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
COMPLEX*16 Z
|
||||
* ..
|
||||
* ..
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC ABS,DBLE,DIMAG
|
||||
*
|
||||
DCABS1 = ABS(DBLE(Z)) + ABS(DIMAG(Z))
|
||||
RETURN
|
||||
END
|
||||
179
lib/linalg/dgesv.f
Normal file
179
lib/linalg/dgesv.f
Normal file
@ -0,0 +1,179 @@
|
||||
*> \brief <b> DGESV computes the solution to system of linear equations A * X = B for GE matrices</b>
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
*> \htmlonly
|
||||
*> Download DGESV + dependencies
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dgesv.f">
|
||||
*> [TGZ]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dgesv.f">
|
||||
*> [ZIP]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dgesv.f">
|
||||
*> [TXT]</a>
|
||||
*> \endhtmlonly
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE DGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER INFO, LDA, LDB, N, NRHS
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* INTEGER IPIV( * )
|
||||
* DOUBLE PRECISION A( LDA, * ), B( LDB, * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> DGESV computes the solution to a real system of linear equations
|
||||
*> A * X = B,
|
||||
*> where A is an N-by-N matrix and X and B are N-by-NRHS matrices.
|
||||
*>
|
||||
*> The LU decomposition with partial pivoting and row interchanges is
|
||||
*> used to factor A as
|
||||
*> A = P * L * U,
|
||||
*> where P is a permutation matrix, L is unit lower triangular, and U is
|
||||
*> upper triangular. The factored form of A is then used to solve the
|
||||
*> system of equations A * X = B.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> The number of linear equations, i.e., the order of the
|
||||
*> matrix A. N >= 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,out] A
|
||||
*> \verbatim
|
||||
*> A is DOUBLE PRECISION array, dimension (LDA,N)
|
||||
*> On entry, the N-by-N coefficient matrix A.
|
||||
*> On exit, the factors L and U from the factorization
|
||||
*> A = P*L*U; the unit diagonal elements of L are not stored.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> The leading dimension of the array A. LDA >= max(1,N).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] IPIV
|
||||
*> \verbatim
|
||||
*> IPIV is INTEGER array, dimension (N)
|
||||
*> The pivot indices that define the permutation matrix P;
|
||||
*> row i of the matrix was interchanged with row IPIV(i).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] B
|
||||
*> \verbatim
|
||||
*> B is DOUBLE PRECISION array, dimension (LDB,NRHS)
|
||||
*> On entry, the N-by-NRHS matrix of right hand side matrix B.
|
||||
*> On exit, if INFO = 0, the N-by-NRHS 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
|
||||
*> > 0: if INFO = i, U(i,i) is exactly zero. The factorization
|
||||
*> has been completed, but the factor U is exactly
|
||||
*> singular, so the solution could not be computed.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup doubleGEsolve
|
||||
*
|
||||
* =====================================================================
|
||||
SUBROUTINE DGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO )
|
||||
*
|
||||
* -- LAPACK driver routine (version 3.4.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER INFO, LDA, LDB, N, NRHS
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
INTEGER IPIV( * )
|
||||
DOUBLE PRECISION A( LDA, * ), B( LDB, * )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL DGETRF, DGETRS, XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC MAX
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* Test the input parameters.
|
||||
*
|
||||
INFO = 0
|
||||
IF( N.LT.0 ) THEN
|
||||
INFO = -1
|
||||
ELSE IF( NRHS.LT.0 ) THEN
|
||||
INFO = -2
|
||||
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
|
||||
INFO = -4
|
||||
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
|
||||
INFO = -7
|
||||
END IF
|
||||
IF( INFO.NE.0 ) THEN
|
||||
CALL XERBLA( 'DGESV ', -INFO )
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Compute the LU factorization of A.
|
||||
*
|
||||
CALL DGETRF( N, N, A, LDA, IPIV, INFO )
|
||||
IF( INFO.EQ.0 ) THEN
|
||||
*
|
||||
* Solve the system A*X = B, overwriting B with X.
|
||||
*
|
||||
CALL DGETRS( 'No transpose', N, NRHS, A, LDA, IPIV, B, LDB,
|
||||
$ INFO )
|
||||
END IF
|
||||
RETURN
|
||||
*
|
||||
* End of DGESV
|
||||
*
|
||||
END
|
||||
225
lib/linalg/dgetrs.f
Normal file
225
lib/linalg/dgetrs.f
Normal file
@ -0,0 +1,225 @@
|
||||
*> \brief \b DGETRS
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
*> \htmlonly
|
||||
*> Download DGETRS + dependencies
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dgetrs.f">
|
||||
*> [TGZ]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dgetrs.f">
|
||||
*> [ZIP]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dgetrs.f">
|
||||
*> [TXT]</a>
|
||||
*> \endhtmlonly
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE DGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* CHARACTER TRANS
|
||||
* INTEGER INFO, LDA, LDB, N, NRHS
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* INTEGER IPIV( * )
|
||||
* DOUBLE PRECISION A( LDA, * ), B( LDB, * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> DGETRS solves a system of linear equations
|
||||
*> A * X = B or A**T * X = B
|
||||
*> with a general N-by-N matrix A using the LU factorization computed
|
||||
*> by DGETRF.
|
||||
*> \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**T* X = B (Conjugate transpose = Transpose)
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> The order of the matrix A. N >= 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] A
|
||||
*> \verbatim
|
||||
*> A is DOUBLE PRECISION array, dimension (LDA,N)
|
||||
*> The factors L and U from the factorization A = P*L*U
|
||||
*> as computed by DGETRF.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> The leading dimension of the array A. LDA >= max(1,N).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] IPIV
|
||||
*> \verbatim
|
||||
*> IPIV is INTEGER array, dimension (N)
|
||||
*> The pivot indices from DGETRF; for 1<=i<=N, row i of the
|
||||
*> matrix was interchanged with row IPIV(i).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] B
|
||||
*> \verbatim
|
||||
*> B is DOUBLE PRECISION 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 November 2011
|
||||
*
|
||||
*> \ingroup doubleGEcomputational
|
||||
*
|
||||
* =====================================================================
|
||||
SUBROUTINE DGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO )
|
||||
*
|
||||
* -- LAPACK computational routine (version 3.4.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
CHARACTER TRANS
|
||||
INTEGER INFO, LDA, LDB, N, NRHS
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
INTEGER IPIV( * )
|
||||
DOUBLE PRECISION A( LDA, * ), B( LDB, * )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
DOUBLE PRECISION ONE
|
||||
PARAMETER ( ONE = 1.0D+0 )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
LOGICAL NOTRAN
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
EXTERNAL LSAME
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL DLASWP, DTRSM, XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC MAX
|
||||
* ..
|
||||
* .. 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( NRHS.LT.0 ) THEN
|
||||
INFO = -3
|
||||
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
|
||||
INFO = -5
|
||||
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
|
||||
INFO = -8
|
||||
END IF
|
||||
IF( INFO.NE.0 ) THEN
|
||||
CALL XERBLA( 'DGETRS', -INFO )
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible
|
||||
*
|
||||
IF( N.EQ.0 .OR. NRHS.EQ.0 )
|
||||
$ RETURN
|
||||
*
|
||||
IF( NOTRAN ) THEN
|
||||
*
|
||||
* Solve A * X = B.
|
||||
*
|
||||
* Apply row interchanges to the right hand sides.
|
||||
*
|
||||
CALL DLASWP( NRHS, B, LDB, 1, N, IPIV, 1 )
|
||||
*
|
||||
* Solve L*X = B, overwriting B with X.
|
||||
*
|
||||
CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit', N, NRHS,
|
||||
$ ONE, A, LDA, B, LDB )
|
||||
*
|
||||
* Solve U*X = B, overwriting B with X.
|
||||
*
|
||||
CALL DTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', N,
|
||||
$ NRHS, ONE, A, LDA, B, LDB )
|
||||
ELSE
|
||||
*
|
||||
* Solve A**T * X = B.
|
||||
*
|
||||
* Solve U**T *X = B, overwriting B with X.
|
||||
*
|
||||
CALL DTRSM( 'Left', 'Upper', 'Transpose', 'Non-unit', N, NRHS,
|
||||
$ ONE, A, LDA, B, LDB )
|
||||
*
|
||||
* Solve L**T *X = B, overwriting B with X.
|
||||
*
|
||||
CALL DTRSM( 'Left', 'Lower', 'Transpose', 'Unit', N, NRHS, ONE,
|
||||
$ A, LDA, B, LDB )
|
||||
*
|
||||
* Apply row interchanges to the solution vectors.
|
||||
*
|
||||
CALL DLASWP( NRHS, B, LDB, 1, N, IPIV, -1 )
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of DGETRS
|
||||
*
|
||||
END
|
||||
128
lib/linalg/dladiv.f
Normal file
128
lib/linalg/dladiv.f
Normal file
@ -0,0 +1,128 @@
|
||||
*> \brief \b DLADIV performs complex division in real arithmetic, avoiding unnecessary overflow.
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
*> \htmlonly
|
||||
*> Download DLADIV + dependencies
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dladiv.f">
|
||||
*> [TGZ]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dladiv.f">
|
||||
*> [ZIP]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dladiv.f">
|
||||
*> [TXT]</a>
|
||||
*> \endhtmlonly
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE DLADIV( A, B, C, D, P, Q )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* DOUBLE PRECISION A, B, C, D, P, Q
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> DLADIV performs complex division in real arithmetic
|
||||
*>
|
||||
*> a + i*b
|
||||
*> p + i*q = ---------
|
||||
*> c + i*d
|
||||
*>
|
||||
*> The algorithm is due to Robert L. Smith and can be found
|
||||
*> in D. Knuth, The art of Computer Programming, Vol.2, p.195
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] A
|
||||
*> \verbatim
|
||||
*> A is DOUBLE PRECISION
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] B
|
||||
*> \verbatim
|
||||
*> B is DOUBLE PRECISION
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] C
|
||||
*> \verbatim
|
||||
*> C is DOUBLE PRECISION
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] D
|
||||
*> \verbatim
|
||||
*> D is DOUBLE PRECISION
|
||||
*> The scalars a, b, c, and d in the above expression.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] P
|
||||
*> \verbatim
|
||||
*> P is DOUBLE PRECISION
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] Q
|
||||
*> \verbatim
|
||||
*> Q is DOUBLE PRECISION
|
||||
*> The scalars p and q in the above expression.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date September 2012
|
||||
*
|
||||
*> \ingroup auxOTHERauxiliary
|
||||
*
|
||||
* =====================================================================
|
||||
SUBROUTINE DLADIV( A, B, C, D, P, Q )
|
||||
*
|
||||
* -- LAPACK auxiliary routine (version 3.4.2) --
|
||||
* -- 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 ..
|
||||
DOUBLE PRECISION A, B, C, D, P, Q
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Local Scalars ..
|
||||
DOUBLE PRECISION E, F
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC ABS
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
IF( ABS( D ).LT.ABS( C ) ) THEN
|
||||
E = D / C
|
||||
F = C + D*E
|
||||
P = ( A+B*E ) / F
|
||||
Q = ( B-A*E ) / F
|
||||
ELSE
|
||||
E = C / D
|
||||
F = D + C*E
|
||||
P = ( B+A*E ) / F
|
||||
Q = ( -A+B*E ) / F
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of DLADIV
|
||||
*
|
||||
END
|
||||
111
lib/linalg/dlapy3.f
Normal file
111
lib/linalg/dlapy3.f
Normal file
@ -0,0 +1,111 @@
|
||||
*> \brief \b DLAPY3 returns sqrt(x2+y2+z2).
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
*> \htmlonly
|
||||
*> Download DLAPY3 + dependencies
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlapy3.f">
|
||||
*> [TGZ]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlapy3.f">
|
||||
*> [ZIP]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlapy3.f">
|
||||
*> [TXT]</a>
|
||||
*> \endhtmlonly
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* DOUBLE PRECISION FUNCTION DLAPY3( X, Y, Z )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* DOUBLE PRECISION X, Y, Z
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> DLAPY3 returns sqrt(x**2+y**2+z**2), taking care not to cause
|
||||
*> unnecessary overflow.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] X
|
||||
*> \verbatim
|
||||
*> X is DOUBLE PRECISION
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] Y
|
||||
*> \verbatim
|
||||
*> Y is DOUBLE PRECISION
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] Z
|
||||
*> \verbatim
|
||||
*> Z is DOUBLE PRECISION
|
||||
*> X, Y and Z specify the values x, y and z.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date September 2012
|
||||
*
|
||||
*> \ingroup auxOTHERauxiliary
|
||||
*
|
||||
* =====================================================================
|
||||
DOUBLE PRECISION FUNCTION DLAPY3( X, Y, Z )
|
||||
*
|
||||
* -- LAPACK auxiliary routine (version 3.4.2) --
|
||||
* -- 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 ..
|
||||
DOUBLE PRECISION X, Y, Z
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
DOUBLE PRECISION ZERO
|
||||
PARAMETER ( ZERO = 0.0D0 )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
DOUBLE PRECISION W, XABS, YABS, ZABS
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC ABS, MAX, SQRT
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
XABS = ABS( X )
|
||||
YABS = ABS( Y )
|
||||
ZABS = ABS( Z )
|
||||
W = MAX( XABS, YABS, ZABS )
|
||||
IF( W.EQ.ZERO ) THEN
|
||||
* W can be zero for max(0,nan,0)
|
||||
* adding all three entries together will make sure
|
||||
* NaN will not disappear.
|
||||
DLAPY3 = XABS + YABS + ZABS
|
||||
ELSE
|
||||
DLAPY3 = W*SQRT( ( XABS / W )**2+( YABS / W )**2+
|
||||
$ ( ZABS / W )**2 )
|
||||
END IF
|
||||
RETURN
|
||||
*
|
||||
* End of DLAPY3
|
||||
*
|
||||
END
|
||||
198
lib/linalg/dorg2l.f
Normal file
198
lib/linalg/dorg2l.f
Normal file
@ -0,0 +1,198 @@
|
||||
*> \brief \b DORG2L generates all or part of the orthogonal matrix Q from a QL factorization determined by sgeqlf (unblocked algorithm).
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
*> \htmlonly
|
||||
*> Download DORG2L + dependencies
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dorg2l.f">
|
||||
*> [TGZ]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dorg2l.f">
|
||||
*> [ZIP]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dorg2l.f">
|
||||
*> [TXT]</a>
|
||||
*> \endhtmlonly
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE DORG2L( M, N, K, A, LDA, TAU, WORK, INFO )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER INFO, K, LDA, M, N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> DORG2L generates an m by n real matrix Q with orthonormal columns,
|
||||
*> which is defined as the last n columns of a product of k elementary
|
||||
*> reflectors of order m
|
||||
*>
|
||||
*> Q = H(k) . . . H(2) H(1)
|
||||
*>
|
||||
*> as returned by DGEQLF.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] M
|
||||
*> \verbatim
|
||||
*> M is INTEGER
|
||||
*> The number of rows of the matrix Q. M >= 0.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> The number of columns of the matrix Q. M >= N >= 0.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] K
|
||||
*> \verbatim
|
||||
*> K is INTEGER
|
||||
*> The number of elementary reflectors whose product defines the
|
||||
*> matrix Q. N >= K >= 0.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] A
|
||||
*> \verbatim
|
||||
*> A is DOUBLE PRECISION array, dimension (LDA,N)
|
||||
*> On entry, the (n-k+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.
|
||||
*> On exit, the m by n matrix Q.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> The first dimension of the array A. LDA >= max(1,M).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] TAU
|
||||
*> \verbatim
|
||||
*> TAU is DOUBLE PRECISION array, dimension (K)
|
||||
*> TAU(i) must contain the scalar factor of the elementary
|
||||
*> reflector H(i), as returned by DGEQLF.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] WORK
|
||||
*> \verbatim
|
||||
*> WORK is DOUBLE PRECISION array, dimension (N)
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] INFO
|
||||
*> \verbatim
|
||||
*> INFO is INTEGER
|
||||
*> = 0: successful exit
|
||||
*> < 0: if INFO = -i, the i-th argument has an illegal value
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date September 2012
|
||||
*
|
||||
*> \ingroup doubleOTHERcomputational
|
||||
*
|
||||
* =====================================================================
|
||||
SUBROUTINE DORG2L( M, N, K, A, LDA, TAU, WORK, INFO )
|
||||
*
|
||||
* -- LAPACK computational routine (version 3.4.2) --
|
||||
* -- 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 ..
|
||||
INTEGER INFO, K, LDA, M, N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
DOUBLE PRECISION ONE, ZERO
|
||||
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
INTEGER I, II, J, L
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL DLARF, DSCAL, XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC MAX
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* Test the input arguments
|
||||
*
|
||||
INFO = 0
|
||||
IF( M.LT.0 ) THEN
|
||||
INFO = -1
|
||||
ELSE IF( N.LT.0 .OR. N.GT.M ) THEN
|
||||
INFO = -2
|
||||
ELSE IF( K.LT.0 .OR. K.GT.N ) THEN
|
||||
INFO = -3
|
||||
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
|
||||
INFO = -5
|
||||
END IF
|
||||
IF( INFO.NE.0 ) THEN
|
||||
CALL XERBLA( 'DORG2L', -INFO )
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible
|
||||
*
|
||||
IF( N.LE.0 )
|
||||
$ RETURN
|
||||
*
|
||||
* Initialise columns 1:n-k to columns of the unit matrix
|
||||
*
|
||||
DO 20 J = 1, N - K
|
||||
DO 10 L = 1, M
|
||||
A( L, J ) = ZERO
|
||||
10 CONTINUE
|
||||
A( M-N+J, J ) = ONE
|
||||
20 CONTINUE
|
||||
*
|
||||
DO 40 I = 1, K
|
||||
II = N - K + I
|
||||
*
|
||||
* 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,
|
||||
$ LDA, WORK )
|
||||
CALL DSCAL( M-N+II-1, -TAU( I ), A( 1, II ), 1 )
|
||||
A( M-N+II, II ) = ONE - TAU( I )
|
||||
*
|
||||
* Set A(m-k+i+1:m,n-k+i) to zero
|
||||
*
|
||||
DO 30 L = M - N + II + 1, M
|
||||
A( L, II ) = ZERO
|
||||
30 CONTINUE
|
||||
40 CONTINUE
|
||||
RETURN
|
||||
*
|
||||
* End of DORG2L
|
||||
*
|
||||
END
|
||||
296
lib/linalg/dorgql.f
Normal file
296
lib/linalg/dorgql.f
Normal file
@ -0,0 +1,296 @@
|
||||
*> \brief \b DORGQL
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
*> \htmlonly
|
||||
*> Download DORGQL + dependencies
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dorgql.f">
|
||||
*> [TGZ]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dorgql.f">
|
||||
*> [ZIP]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dorgql.f">
|
||||
*> [TXT]</a>
|
||||
*> \endhtmlonly
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE DORGQL( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER INFO, K, LDA, LWORK, M, N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> DORGQL generates an M-by-N real matrix Q with orthonormal columns,
|
||||
*> which is defined as the last N columns of a product of K elementary
|
||||
*> reflectors of order M
|
||||
*>
|
||||
*> Q = H(k) . . . H(2) H(1)
|
||||
*>
|
||||
*> as returned by DGEQLF.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] M
|
||||
*> \verbatim
|
||||
*> M is INTEGER
|
||||
*> The number of rows of the matrix Q. M >= 0.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> The number of columns of the matrix Q. M >= N >= 0.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] K
|
||||
*> \verbatim
|
||||
*> K is INTEGER
|
||||
*> The number of elementary reflectors whose product defines the
|
||||
*> matrix Q. N >= K >= 0.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] A
|
||||
*> \verbatim
|
||||
*> A is DOUBLE PRECISION array, dimension (LDA,N)
|
||||
*> On entry, the (n-k+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.
|
||||
*> On exit, the M-by-N matrix Q.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> The first dimension of the array A. LDA >= max(1,M).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] TAU
|
||||
*> \verbatim
|
||||
*> TAU is DOUBLE PRECISION array, dimension (K)
|
||||
*> TAU(i) must contain the scalar factor of the elementary
|
||||
*> reflector H(i), as returned by DGEQLF.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] WORK
|
||||
*> \verbatim
|
||||
*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK))
|
||||
*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LWORK
|
||||
*> \verbatim
|
||||
*> LWORK is INTEGER
|
||||
*> The dimension of the array WORK. LWORK >= max(1,N).
|
||||
*> For optimum performance LWORK >= N*NB, where NB is the
|
||||
*> optimal blocksize.
|
||||
*>
|
||||
*> If LWORK = -1, then a workspace query is assumed; the routine
|
||||
*> only calculates the optimal size of the WORK array, returns
|
||||
*> this value as the first entry of the WORK array, and no error
|
||||
*> message related to LWORK is issued by XERBLA.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] INFO
|
||||
*> \verbatim
|
||||
*> INFO is INTEGER
|
||||
*> = 0: successful exit
|
||||
*> < 0: if INFO = -i, the i-th argument has an illegal value
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup doubleOTHERcomputational
|
||||
*
|
||||
* =====================================================================
|
||||
SUBROUTINE DORGQL( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
|
||||
*
|
||||
* -- LAPACK computational routine (version 3.4.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER INFO, K, LDA, LWORK, M, N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
DOUBLE PRECISION ZERO
|
||||
PARAMETER ( ZERO = 0.0D+0 )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
LOGICAL LQUERY
|
||||
INTEGER I, IB, IINFO, IWS, J, KK, L, LDWORK, LWKOPT,
|
||||
$ NB, NBMIN, NX
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL DLARFB, DLARFT, DORG2L, XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC MAX, MIN
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
INTEGER ILAENV
|
||||
EXTERNAL ILAENV
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* Test the input arguments
|
||||
*
|
||||
INFO = 0
|
||||
LQUERY = ( LWORK.EQ.-1 )
|
||||
IF( M.LT.0 ) THEN
|
||||
INFO = -1
|
||||
ELSE IF( N.LT.0 .OR. N.GT.M ) THEN
|
||||
INFO = -2
|
||||
ELSE IF( K.LT.0 .OR. K.GT.N ) THEN
|
||||
INFO = -3
|
||||
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
|
||||
INFO = -5
|
||||
END IF
|
||||
*
|
||||
IF( INFO.EQ.0 ) THEN
|
||||
IF( N.EQ.0 ) THEN
|
||||
LWKOPT = 1
|
||||
ELSE
|
||||
NB = ILAENV( 1, 'DORGQL', ' ', M, N, K, -1 )
|
||||
LWKOPT = N*NB
|
||||
END IF
|
||||
WORK( 1 ) = LWKOPT
|
||||
*
|
||||
IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN
|
||||
INFO = -8
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
IF( INFO.NE.0 ) THEN
|
||||
CALL XERBLA( 'DORGQL', -INFO )
|
||||
RETURN
|
||||
ELSE IF( LQUERY ) THEN
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible
|
||||
*
|
||||
IF( N.LE.0 ) THEN
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
NBMIN = 2
|
||||
NX = 0
|
||||
IWS = N
|
||||
IF( NB.GT.1 .AND. NB.LT.K ) THEN
|
||||
*
|
||||
* Determine when to cross over from blocked to unblocked code.
|
||||
*
|
||||
NX = MAX( 0, ILAENV( 3, 'DORGQL', ' ', M, N, K, -1 ) )
|
||||
IF( NX.LT.K ) THEN
|
||||
*
|
||||
* Determine if workspace is large enough for blocked code.
|
||||
*
|
||||
LDWORK = N
|
||||
IWS = LDWORK*NB
|
||||
IF( LWORK.LT.IWS ) THEN
|
||||
*
|
||||
* Not enough workspace to use optimal NB: reduce NB and
|
||||
* determine the minimum value of NB.
|
||||
*
|
||||
NB = LWORK / LDWORK
|
||||
NBMIN = MAX( 2, ILAENV( 2, 'DORGQL', ' ', M, N, K, -1 ) )
|
||||
END IF
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN
|
||||
*
|
||||
* Use blocked code after the first block.
|
||||
* The last kk columns are handled by the block method.
|
||||
*
|
||||
KK = MIN( K, ( ( K-NX+NB-1 ) / NB )*NB )
|
||||
*
|
||||
* Set A(m-kk+1:m,1:n-kk) to zero.
|
||||
*
|
||||
DO 20 J = 1, N - KK
|
||||
DO 10 I = M - KK + 1, M
|
||||
A( I, J ) = ZERO
|
||||
10 CONTINUE
|
||||
20 CONTINUE
|
||||
ELSE
|
||||
KK = 0
|
||||
END IF
|
||||
*
|
||||
* Use unblocked code for the first or only block.
|
||||
*
|
||||
CALL DORG2L( M-KK, N-KK, K-KK, A, LDA, TAU, WORK, IINFO )
|
||||
*
|
||||
IF( KK.GT.0 ) THEN
|
||||
*
|
||||
* Use blocked code
|
||||
*
|
||||
DO 50 I = K - KK + 1, K, NB
|
||||
IB = MIN( NB, K-I+1 )
|
||||
IF( N-K+I.GT.1 ) THEN
|
||||
*
|
||||
* Form the triangular factor of the block reflector
|
||||
* H = H(i+ib-1) . . . H(i+1) H(i)
|
||||
*
|
||||
CALL DLARFT( 'Backward', 'Columnwise', M-K+I+IB-1, IB,
|
||||
$ A( 1, N-K+I ), LDA, TAU( I ), WORK, LDWORK )
|
||||
*
|
||||
* Apply H to A(1:m-k+i+ib-1,1:n-k+i-1) from the left
|
||||
*
|
||||
CALL DLARFB( 'Left', 'No transpose', 'Backward',
|
||||
$ 'Columnwise', M-K+I+IB-1, N-K+I-1, IB,
|
||||
$ A( 1, N-K+I ), LDA, WORK, LDWORK, A, LDA,
|
||||
$ WORK( IB+1 ), LDWORK )
|
||||
END IF
|
||||
*
|
||||
* Apply H to rows 1:m-k+i+ib-1 of current block
|
||||
*
|
||||
CALL DORG2L( M-K+I+IB-1, IB, IB, A( 1, N-K+I ), LDA,
|
||||
$ TAU( I ), WORK, IINFO )
|
||||
*
|
||||
* Set rows m-k+i+ib:m of current block to zero
|
||||
*
|
||||
DO 40 J = N - K + I, N - K + I + IB - 1
|
||||
DO 30 L = M - K + I + IB, M
|
||||
A( L, J ) = ZERO
|
||||
30 CONTINUE
|
||||
40 CONTINUE
|
||||
50 CONTINUE
|
||||
END IF
|
||||
*
|
||||
WORK( 1 ) = IWS
|
||||
RETURN
|
||||
*
|
||||
* End of DORGQL
|
||||
*
|
||||
END
|
||||
255
lib/linalg/dorgtr.f
Normal file
255
lib/linalg/dorgtr.f
Normal file
@ -0,0 +1,255 @@
|
||||
*> \brief \b DORGTR
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
*> \htmlonly
|
||||
*> Download DORGTR + dependencies
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dorgtr.f">
|
||||
*> [TGZ]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dorgtr.f">
|
||||
*> [ZIP]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dorgtr.f">
|
||||
*> [TXT]</a>
|
||||
*> \endhtmlonly
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE DORGTR( UPLO, N, A, LDA, TAU, WORK, LWORK, INFO )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* CHARACTER UPLO
|
||||
* INTEGER INFO, LDA, LWORK, N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> DORGTR generates a real orthogonal matrix Q which is defined as the
|
||||
*> product of n-1 elementary reflectors of order N, as returned by
|
||||
*> DSYTRD:
|
||||
*>
|
||||
*> if UPLO = 'U', Q = H(n-1) . . . H(2) H(1),
|
||||
*>
|
||||
*> if UPLO = 'L', Q = H(1) H(2) . . . H(n-1).
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] UPLO
|
||||
*> \verbatim
|
||||
*> UPLO is CHARACTER*1
|
||||
*> = 'U': Upper triangle of A contains elementary reflectors
|
||||
*> from DSYTRD;
|
||||
*> = 'L': Lower triangle of A contains elementary reflectors
|
||||
*> from DSYTRD.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> The order of the matrix Q. N >= 0.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] A
|
||||
*> \verbatim
|
||||
*> A is DOUBLE PRECISION array, dimension (LDA,N)
|
||||
*> On entry, the vectors which define the elementary reflectors,
|
||||
*> as returned by DSYTRD.
|
||||
*> On exit, the N-by-N orthogonal matrix Q.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> The leading dimension of the array A. LDA >= max(1,N).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] TAU
|
||||
*> \verbatim
|
||||
*> TAU is DOUBLE PRECISION array, dimension (N-1)
|
||||
*> TAU(i) must contain the scalar factor of the elementary
|
||||
*> reflector H(i), as returned by DSYTRD.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] WORK
|
||||
*> \verbatim
|
||||
*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK))
|
||||
*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LWORK
|
||||
*> \verbatim
|
||||
*> LWORK is INTEGER
|
||||
*> The dimension of the array WORK. LWORK >= max(1,N-1).
|
||||
*> For optimum performance LWORK >= (N-1)*NB, where NB is
|
||||
*> the optimal blocksize.
|
||||
*>
|
||||
*> If LWORK = -1, then a workspace query is assumed; the routine
|
||||
*> only calculates the optimal size of the WORK array, returns
|
||||
*> this value as the first entry of the WORK array, and no error
|
||||
*> message related to LWORK is issued by XERBLA.
|
||||
*> \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 November 2011
|
||||
*
|
||||
*> \ingroup doubleOTHERcomputational
|
||||
*
|
||||
* =====================================================================
|
||||
SUBROUTINE DORGTR( UPLO, N, A, LDA, TAU, WORK, LWORK, INFO )
|
||||
*
|
||||
* -- LAPACK computational routine (version 3.4.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
CHARACTER UPLO
|
||||
INTEGER INFO, LDA, LWORK, N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
DOUBLE PRECISION ZERO, ONE
|
||||
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
LOGICAL LQUERY, UPPER
|
||||
INTEGER I, IINFO, J, LWKOPT, NB
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
INTEGER ILAENV
|
||||
EXTERNAL LSAME, ILAENV
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL DORGQL, DORGQR, XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC MAX
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* Test the input arguments
|
||||
*
|
||||
INFO = 0
|
||||
LQUERY = ( LWORK.EQ.-1 )
|
||||
UPPER = LSAME( UPLO, 'U' )
|
||||
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
|
||||
INFO = -1
|
||||
ELSE IF( N.LT.0 ) THEN
|
||||
INFO = -2
|
||||
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
|
||||
INFO = -4
|
||||
ELSE IF( LWORK.LT.MAX( 1, N-1 ) .AND. .NOT.LQUERY ) THEN
|
||||
INFO = -7
|
||||
END IF
|
||||
*
|
||||
IF( INFO.EQ.0 ) THEN
|
||||
IF( UPPER ) THEN
|
||||
NB = ILAENV( 1, 'DORGQL', ' ', N-1, N-1, N-1, -1 )
|
||||
ELSE
|
||||
NB = ILAENV( 1, 'DORGQR', ' ', N-1, N-1, N-1, -1 )
|
||||
END IF
|
||||
LWKOPT = MAX( 1, N-1 )*NB
|
||||
WORK( 1 ) = LWKOPT
|
||||
END IF
|
||||
*
|
||||
IF( INFO.NE.0 ) THEN
|
||||
CALL XERBLA( 'DORGTR', -INFO )
|
||||
RETURN
|
||||
ELSE IF( LQUERY ) THEN
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible
|
||||
*
|
||||
IF( N.EQ.0 ) THEN
|
||||
WORK( 1 ) = 1
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
IF( UPPER ) THEN
|
||||
*
|
||||
* Q was determined by a call to DSYTRD with UPLO = 'U'
|
||||
*
|
||||
* Shift the vectors which define the elementary reflectors one
|
||||
* column to the left, and set the last row and column of Q to
|
||||
* those of the unit matrix
|
||||
*
|
||||
DO 20 J = 1, N - 1
|
||||
DO 10 I = 1, J - 1
|
||||
A( I, J ) = A( I, J+1 )
|
||||
10 CONTINUE
|
||||
A( N, J ) = ZERO
|
||||
20 CONTINUE
|
||||
DO 30 I = 1, N - 1
|
||||
A( I, N ) = ZERO
|
||||
30 CONTINUE
|
||||
A( N, N ) = ONE
|
||||
*
|
||||
* Generate Q(1:n-1,1:n-1)
|
||||
*
|
||||
CALL DORGQL( N-1, N-1, N-1, A, LDA, TAU, WORK, LWORK, IINFO )
|
||||
*
|
||||
ELSE
|
||||
*
|
||||
* Q was determined by a call to DSYTRD with UPLO = 'L'.
|
||||
*
|
||||
* Shift the vectors which define the elementary reflectors one
|
||||
* column to the right, and set the first row and column of Q to
|
||||
* those of the unit matrix
|
||||
*
|
||||
DO 50 J = N, 2, -1
|
||||
A( 1, J ) = ZERO
|
||||
DO 40 I = J + 1, N
|
||||
A( I, J ) = A( I, J-1 )
|
||||
40 CONTINUE
|
||||
50 CONTINUE
|
||||
A( 1, 1 ) = ONE
|
||||
DO 60 I = 2, N
|
||||
A( I, 1 ) = ZERO
|
||||
60 CONTINUE
|
||||
IF( N.GT.1 ) THEN
|
||||
*
|
||||
* Generate Q(2:n,2:n)
|
||||
*
|
||||
CALL DORGQR( N-1, N-1, N-1, A( 2, 2 ), LDA, TAU, WORK,
|
||||
$ LWORK, IINFO )
|
||||
END IF
|
||||
END IF
|
||||
WORK( 1 ) = LWKOPT
|
||||
RETURN
|
||||
*
|
||||
* End of DORGTR
|
||||
*
|
||||
END
|
||||
286
lib/linalg/dsyev.f
Normal file
286
lib/linalg/dsyev.f
Normal file
@ -0,0 +1,286 @@
|
||||
*> \brief <b> DSYEV computes the eigenvalues and, optionally, the left and/or right eigenvectors for SY matrices</b>
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
*> \htmlonly
|
||||
*> Download DSYEV + dependencies
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dsyev.f">
|
||||
*> [TGZ]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dsyev.f">
|
||||
*> [ZIP]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dsyev.f">
|
||||
*> [TXT]</a>
|
||||
*> \endhtmlonly
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE DSYEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, INFO )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* CHARACTER JOBZ, UPLO
|
||||
* INTEGER INFO, LDA, LWORK, N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* DOUBLE PRECISION A( LDA, * ), W( * ), WORK( * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> DSYEV computes all eigenvalues and, optionally, eigenvectors of a
|
||||
*> real symmetric matrix A.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] JOBZ
|
||||
*> \verbatim
|
||||
*> JOBZ is CHARACTER*1
|
||||
*> = 'N': Compute eigenvalues only;
|
||||
*> = 'V': Compute eigenvalues and eigenvectors.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] UPLO
|
||||
*> \verbatim
|
||||
*> UPLO is CHARACTER*1
|
||||
*> = 'U': Upper triangle of A is stored;
|
||||
*> = 'L': Lower triangle of A is stored.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> The order of the matrix A. N >= 0.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] A
|
||||
*> \verbatim
|
||||
*> A is DOUBLE PRECISION array, dimension (LDA, N)
|
||||
*> On entry, the symmetric matrix A. If UPLO = 'U', the
|
||||
*> leading N-by-N upper triangular part of A contains the
|
||||
*> upper triangular part of the matrix A. If UPLO = 'L',
|
||||
*> the leading N-by-N lower triangular part of A contains
|
||||
*> the lower triangular part of the matrix A.
|
||||
*> On exit, if JOBZ = 'V', then if INFO = 0, A contains the
|
||||
*> orthonormal eigenvectors of the matrix A.
|
||||
*> If JOBZ = 'N', then on exit the lower triangle (if UPLO='L')
|
||||
*> or the upper triangle (if UPLO='U') of A, including the
|
||||
*> diagonal, is destroyed.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> The leading dimension of the array A. LDA >= max(1,N).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] W
|
||||
*> \verbatim
|
||||
*> W is DOUBLE PRECISION array, dimension (N)
|
||||
*> If INFO = 0, the eigenvalues in ascending order.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] WORK
|
||||
*> \verbatim
|
||||
*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK))
|
||||
*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LWORK
|
||||
*> \verbatim
|
||||
*> LWORK is INTEGER
|
||||
*> The length of the array WORK. LWORK >= max(1,3*N-1).
|
||||
*> For optimal efficiency, LWORK >= (NB+2)*N,
|
||||
*> where NB is the blocksize for DSYTRD returned by ILAENV.
|
||||
*>
|
||||
*> If LWORK = -1, then a workspace query is assumed; the routine
|
||||
*> only calculates the optimal size of the WORK array, returns
|
||||
*> this value as the first entry of the WORK array, and no error
|
||||
*> message related to LWORK is issued by XERBLA.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] INFO
|
||||
*> \verbatim
|
||||
*> INFO is INTEGER
|
||||
*> = 0: successful exit
|
||||
*> < 0: if INFO = -i, the i-th argument had an illegal value
|
||||
*> > 0: if INFO = i, the algorithm failed to converge; i
|
||||
*> off-diagonal elements of an intermediate tridiagonal
|
||||
*> form did not converge to zero.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup doubleSYeigen
|
||||
*
|
||||
* =====================================================================
|
||||
SUBROUTINE DSYEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, INFO )
|
||||
*
|
||||
* -- LAPACK driver routine (version 3.4.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
CHARACTER JOBZ, UPLO
|
||||
INTEGER INFO, LDA, LWORK, N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION A( LDA, * ), W( * ), WORK( * )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
DOUBLE PRECISION ZERO, ONE
|
||||
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
LOGICAL LOWER, LQUERY, WANTZ
|
||||
INTEGER IINFO, IMAX, INDE, INDTAU, INDWRK, ISCALE,
|
||||
$ LLWORK, LWKOPT, NB
|
||||
DOUBLE PRECISION ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA,
|
||||
$ SMLNUM
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
INTEGER ILAENV
|
||||
DOUBLE PRECISION DLAMCH, DLANSY
|
||||
EXTERNAL LSAME, ILAENV, DLAMCH, DLANSY
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL DLASCL, DORGTR, DSCAL, DSTEQR, DSTERF, DSYTRD,
|
||||
$ XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC MAX, SQRT
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* Test the input parameters.
|
||||
*
|
||||
WANTZ = LSAME( JOBZ, 'V' )
|
||||
LOWER = LSAME( UPLO, 'L' )
|
||||
LQUERY = ( LWORK.EQ.-1 )
|
||||
*
|
||||
INFO = 0
|
||||
IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
|
||||
INFO = -1
|
||||
ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN
|
||||
INFO = -2
|
||||
ELSE IF( N.LT.0 ) THEN
|
||||
INFO = -3
|
||||
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
|
||||
INFO = -5
|
||||
END IF
|
||||
*
|
||||
IF( INFO.EQ.0 ) THEN
|
||||
NB = ILAENV( 1, 'DSYTRD', UPLO, N, -1, -1, -1 )
|
||||
LWKOPT = MAX( 1, ( NB+2 )*N )
|
||||
WORK( 1 ) = LWKOPT
|
||||
*
|
||||
IF( LWORK.LT.MAX( 1, 3*N-1 ) .AND. .NOT.LQUERY )
|
||||
$ INFO = -8
|
||||
END IF
|
||||
*
|
||||
IF( INFO.NE.0 ) THEN
|
||||
CALL XERBLA( 'DSYEV ', -INFO )
|
||||
RETURN
|
||||
ELSE IF( LQUERY ) THEN
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible
|
||||
*
|
||||
IF( N.EQ.0 ) THEN
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
IF( N.EQ.1 ) THEN
|
||||
W( 1 ) = A( 1, 1 )
|
||||
WORK( 1 ) = 2
|
||||
IF( WANTZ )
|
||||
$ A( 1, 1 ) = ONE
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Get machine constants.
|
||||
*
|
||||
SAFMIN = DLAMCH( 'Safe minimum' )
|
||||
EPS = DLAMCH( 'Precision' )
|
||||
SMLNUM = SAFMIN / EPS
|
||||
BIGNUM = ONE / SMLNUM
|
||||
RMIN = SQRT( SMLNUM )
|
||||
RMAX = SQRT( BIGNUM )
|
||||
*
|
||||
* Scale matrix to allowable range, if necessary.
|
||||
*
|
||||
ANRM = DLANSY( 'M', UPLO, N, A, LDA, WORK )
|
||||
ISCALE = 0
|
||||
IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN
|
||||
ISCALE = 1
|
||||
SIGMA = RMIN / ANRM
|
||||
ELSE IF( ANRM.GT.RMAX ) THEN
|
||||
ISCALE = 1
|
||||
SIGMA = RMAX / ANRM
|
||||
END IF
|
||||
IF( ISCALE.EQ.1 )
|
||||
$ CALL DLASCL( UPLO, 0, 0, ONE, SIGMA, N, N, A, LDA, INFO )
|
||||
*
|
||||
* Call DSYTRD to reduce symmetric matrix to tridiagonal form.
|
||||
*
|
||||
INDE = 1
|
||||
INDTAU = INDE + N
|
||||
INDWRK = INDTAU + N
|
||||
LLWORK = LWORK - INDWRK + 1
|
||||
CALL DSYTRD( UPLO, N, A, LDA, W, WORK( INDE ), WORK( INDTAU ),
|
||||
$ WORK( INDWRK ), LLWORK, IINFO )
|
||||
*
|
||||
* For eigenvalues only, call DSTERF. For eigenvectors, first call
|
||||
* DORGTR to generate the orthogonal matrix, then call DSTEQR.
|
||||
*
|
||||
IF( .NOT.WANTZ ) THEN
|
||||
CALL DSTERF( N, W, WORK( INDE ), INFO )
|
||||
ELSE
|
||||
CALL DORGTR( UPLO, N, A, LDA, WORK( INDTAU ), WORK( INDWRK ),
|
||||
$ LLWORK, IINFO )
|
||||
CALL DSTEQR( JOBZ, N, W, WORK( INDE ), A, LDA, WORK( INDTAU ),
|
||||
$ INFO )
|
||||
END IF
|
||||
*
|
||||
* If matrix was scaled, then rescale eigenvalues appropriately.
|
||||
*
|
||||
IF( ISCALE.EQ.1 ) THEN
|
||||
IF( INFO.EQ.0 ) THEN
|
||||
IMAX = N
|
||||
ELSE
|
||||
IMAX = INFO - 1
|
||||
END IF
|
||||
CALL DSCAL( IMAX, ONE / SIGMA, W, 1 )
|
||||
END IF
|
||||
*
|
||||
* Set WORK(1) to optimal workspace size.
|
||||
*
|
||||
WORK( 1 ) = LWKOPT
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of DSYEV
|
||||
*
|
||||
END
|
||||
314
lib/linalg/dsygv.f
Normal file
314
lib/linalg/dsygv.f
Normal file
@ -0,0 +1,314 @@
|
||||
*> \brief \b DSYGST
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
*> \htmlonly
|
||||
*> Download DSYGV + dependencies
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dsygv.f">
|
||||
*> [TGZ]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dsygv.f">
|
||||
*> [ZIP]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dsygv.f">
|
||||
*> [TXT]</a>
|
||||
*> \endhtmlonly
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE DSYGV( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK,
|
||||
* LWORK, INFO )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* CHARACTER JOBZ, UPLO
|
||||
* INTEGER INFO, ITYPE, LDA, LDB, LWORK, N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), W( * ), WORK( * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> DSYGV computes all the eigenvalues, and optionally, the eigenvectors
|
||||
*> of a real generalized symmetric-definite eigenproblem, of the form
|
||||
*> A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x.
|
||||
*> Here A and B are assumed to be symmetric and B is also
|
||||
*> positive definite.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] ITYPE
|
||||
*> \verbatim
|
||||
*> ITYPE is INTEGER
|
||||
*> Specifies the problem type to be solved:
|
||||
*> = 1: A*x = (lambda)*B*x
|
||||
*> = 2: A*B*x = (lambda)*x
|
||||
*> = 3: B*A*x = (lambda)*x
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] JOBZ
|
||||
*> \verbatim
|
||||
*> JOBZ is CHARACTER*1
|
||||
*> = 'N': Compute eigenvalues only;
|
||||
*> = 'V': Compute eigenvalues and eigenvectors.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] UPLO
|
||||
*> \verbatim
|
||||
*> UPLO is CHARACTER*1
|
||||
*> = 'U': Upper triangles of A and B are stored;
|
||||
*> = 'L': Lower triangles of A and B are stored.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> The order of the matrices A and B. N >= 0.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] A
|
||||
*> \verbatim
|
||||
*> A is DOUBLE PRECISION array, dimension (LDA, N)
|
||||
*> On entry, the symmetric matrix A. If UPLO = 'U', the
|
||||
*> leading N-by-N upper triangular part of A contains the
|
||||
*> upper triangular part of the matrix A. If UPLO = 'L',
|
||||
*> the leading N-by-N lower triangular part of A contains
|
||||
*> the lower triangular part of the matrix A.
|
||||
*>
|
||||
*> On exit, if JOBZ = 'V', then if INFO = 0, A contains the
|
||||
*> matrix Z of eigenvectors. The eigenvectors are normalized
|
||||
*> as follows:
|
||||
*> if ITYPE = 1 or 2, Z**T*B*Z = I;
|
||||
*> if ITYPE = 3, Z**T*inv(B)*Z = I.
|
||||
*> If JOBZ = 'N', then on exit the upper triangle (if UPLO='U')
|
||||
*> or the lower triangle (if UPLO='L') of A, including the
|
||||
*> diagonal, is destroyed.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> The leading dimension of the array A. LDA >= max(1,N).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] B
|
||||
*> \verbatim
|
||||
*> B is DOUBLE PRECISION array, dimension (LDB, N)
|
||||
*> On entry, the symmetric positive definite matrix B.
|
||||
*> If UPLO = 'U', the leading N-by-N upper triangular part of B
|
||||
*> contains the upper triangular part of the matrix B.
|
||||
*> If UPLO = 'L', the leading N-by-N lower triangular part of B
|
||||
*> contains the lower triangular part of the matrix B.
|
||||
*>
|
||||
*> On exit, if INFO <= N, the part of B containing the matrix is
|
||||
*> overwritten by the triangular factor U or L from the Cholesky
|
||||
*> factorization B = U**T*U or B = L*L**T.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDB
|
||||
*> \verbatim
|
||||
*> LDB is INTEGER
|
||||
*> The leading dimension of the array B. LDB >= max(1,N).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] W
|
||||
*> \verbatim
|
||||
*> W is DOUBLE PRECISION array, dimension (N)
|
||||
*> If INFO = 0, the eigenvalues in ascending order.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] WORK
|
||||
*> \verbatim
|
||||
*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK))
|
||||
*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LWORK
|
||||
*> \verbatim
|
||||
*> LWORK is INTEGER
|
||||
*> The length of the array WORK. LWORK >= max(1,3*N-1).
|
||||
*> For optimal efficiency, LWORK >= (NB+2)*N,
|
||||
*> where NB is the blocksize for DSYTRD returned by ILAENV.
|
||||
*>
|
||||
*> If LWORK = -1, then a workspace query is assumed; the routine
|
||||
*> only calculates the optimal size of the WORK array, returns
|
||||
*> this value as the first entry of the WORK array, and no error
|
||||
*> message related to LWORK is issued by XERBLA.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] INFO
|
||||
*> \verbatim
|
||||
*> INFO is INTEGER
|
||||
*> = 0: successful exit
|
||||
*> < 0: if INFO = -i, the i-th argument had an illegal value
|
||||
*> > 0: DPOTRF or DSYEV returned an error code:
|
||||
*> <= N: if INFO = i, DSYEV failed to converge;
|
||||
*> i off-diagonal elements of an intermediate
|
||||
*> tridiagonal form did not converge to zero;
|
||||
*> > N: if INFO = N + i, for 1 <= i <= N, then the leading
|
||||
*> minor of order i of B is not positive definite.
|
||||
*> The factorization of B could not be completed and
|
||||
*> no eigenvalues or eigenvectors were computed.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup doubleSYeigen
|
||||
*
|
||||
* =====================================================================
|
||||
SUBROUTINE DSYGV( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK,
|
||||
$ LWORK, INFO )
|
||||
*
|
||||
* -- LAPACK driver routine (version 3.4.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
CHARACTER JOBZ, UPLO
|
||||
INTEGER INFO, ITYPE, LDA, LDB, LWORK, N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION A( LDA, * ), B( LDB, * ), W( * ), WORK( * )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
DOUBLE PRECISION ONE
|
||||
PARAMETER ( ONE = 1.0D+0 )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
LOGICAL LQUERY, UPPER, WANTZ
|
||||
CHARACTER TRANS
|
||||
INTEGER LWKMIN, LWKOPT, NB, NEIG
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
INTEGER ILAENV
|
||||
EXTERNAL LSAME, ILAENV
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL DPOTRF, DSYEV, DSYGST, DTRMM, DTRSM, XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC MAX
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* Test the input parameters.
|
||||
*
|
||||
WANTZ = LSAME( JOBZ, 'V' )
|
||||
UPPER = LSAME( UPLO, 'U' )
|
||||
LQUERY = ( LWORK.EQ.-1 )
|
||||
*
|
||||
INFO = 0
|
||||
IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN
|
||||
INFO = -1
|
||||
ELSE IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
|
||||
INFO = -2
|
||||
ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN
|
||||
INFO = -3
|
||||
ELSE IF( N.LT.0 ) THEN
|
||||
INFO = -4
|
||||
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
|
||||
INFO = -6
|
||||
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
|
||||
INFO = -8
|
||||
END IF
|
||||
*
|
||||
IF( INFO.EQ.0 ) THEN
|
||||
LWKMIN = MAX( 1, 3*N - 1 )
|
||||
NB = ILAENV( 1, 'DSYTRD', UPLO, N, -1, -1, -1 )
|
||||
LWKOPT = MAX( LWKMIN, ( NB + 2 )*N )
|
||||
WORK( 1 ) = LWKOPT
|
||||
*
|
||||
IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY ) THEN
|
||||
INFO = -11
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
IF( INFO.NE.0 ) THEN
|
||||
CALL XERBLA( 'DSYGV ', -INFO )
|
||||
RETURN
|
||||
ELSE IF( LQUERY ) THEN
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible
|
||||
*
|
||||
IF( N.EQ.0 )
|
||||
$ RETURN
|
||||
*
|
||||
* Form a Cholesky factorization of B.
|
||||
*
|
||||
CALL DPOTRF( UPLO, N, B, LDB, INFO )
|
||||
IF( INFO.NE.0 ) THEN
|
||||
INFO = N + INFO
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Transform problem to standard eigenvalue problem and solve.
|
||||
*
|
||||
CALL DSYGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO )
|
||||
CALL DSYEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, INFO )
|
||||
*
|
||||
IF( WANTZ ) THEN
|
||||
*
|
||||
* Backtransform eigenvectors to the original problem.
|
||||
*
|
||||
NEIG = N
|
||||
IF( INFO.GT.0 )
|
||||
$ NEIG = INFO - 1
|
||||
IF( ITYPE.EQ.1 .OR. ITYPE.EQ.2 ) THEN
|
||||
*
|
||||
* For A*x=(lambda)*B*x and A*B*x=(lambda)*x;
|
||||
* backtransform eigenvectors: x = inv(L)**T*y or inv(U)*y
|
||||
*
|
||||
IF( UPPER ) THEN
|
||||
TRANS = 'N'
|
||||
ELSE
|
||||
TRANS = 'T'
|
||||
END IF
|
||||
*
|
||||
CALL DTRSM( 'Left', UPLO, TRANS, 'Non-unit', N, NEIG, ONE,
|
||||
$ B, LDB, A, LDA )
|
||||
*
|
||||
ELSE IF( ITYPE.EQ.3 ) THEN
|
||||
*
|
||||
* For B*A*x=(lambda)*x;
|
||||
* backtransform eigenvectors: x = L*y or U**T*y
|
||||
*
|
||||
IF( UPPER ) THEN
|
||||
TRANS = 'T'
|
||||
ELSE
|
||||
TRANS = 'N'
|
||||
END IF
|
||||
*
|
||||
CALL DTRMM( 'Left', UPLO, TRANS, 'Non-unit', N, NEIG, ONE,
|
||||
$ B, LDB, A, LDA )
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
WORK( 1 ) = LWKOPT
|
||||
RETURN
|
||||
*
|
||||
* End of DSYGV
|
||||
*
|
||||
END
|
||||
119
lib/linalg/dznrm2.f
Normal file
119
lib/linalg/dznrm2.f
Normal file
@ -0,0 +1,119 @@
|
||||
*> \brief \b DZNRM2
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* DOUBLE PRECISION FUNCTION DZNRM2(N,X,INCX)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER INCX,N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* COMPLEX*16 X(*)
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> DZNRM2 returns the euclidean norm of a vector via the function
|
||||
*> name, so that
|
||||
*>
|
||||
*> DZNRM2 := sqrt( x**H*x )
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup double_blas_level1
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> -- This version written on 25-October-1982.
|
||||
*> Modified on 14-October-1993 to inline the call to ZLASSQ.
|
||||
*> Sven Hammarling, Nag Ltd.
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
DOUBLE PRECISION FUNCTION DZNRM2(N,X,INCX)
|
||||
*
|
||||
* -- Reference BLAS level1 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER INCX,N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
COMPLEX*16 X(*)
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
DOUBLE PRECISION ONE,ZERO
|
||||
PARAMETER (ONE=1.0D+0,ZERO=0.0D+0)
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
DOUBLE PRECISION NORM,SCALE,SSQ,TEMP
|
||||
INTEGER IX
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC ABS,DBLE,DIMAG,SQRT
|
||||
* ..
|
||||
IF (N.LT.1 .OR. INCX.LT.1) THEN
|
||||
NORM = ZERO
|
||||
ELSE
|
||||
SCALE = ZERO
|
||||
SSQ = ONE
|
||||
* The following loop is equivalent to this call to the LAPACK
|
||||
* auxiliary routine:
|
||||
* CALL ZLASSQ( N, X, INCX, SCALE, SSQ )
|
||||
*
|
||||
DO 10 IX = 1,1 + (N-1)*INCX,INCX
|
||||
IF (DBLE(X(IX)).NE.ZERO) THEN
|
||||
TEMP = ABS(DBLE(X(IX)))
|
||||
IF (SCALE.LT.TEMP) THEN
|
||||
SSQ = ONE + SSQ* (SCALE/TEMP)**2
|
||||
SCALE = TEMP
|
||||
ELSE
|
||||
SSQ = SSQ + (TEMP/SCALE)**2
|
||||
END IF
|
||||
END IF
|
||||
IF (DIMAG(X(IX)).NE.ZERO) THEN
|
||||
TEMP = ABS(DIMAG(X(IX)))
|
||||
IF (SCALE.LT.TEMP) THEN
|
||||
SSQ = ONE + SSQ* (SCALE/TEMP)**2
|
||||
SCALE = TEMP
|
||||
ELSE
|
||||
SSQ = SSQ + (TEMP/SCALE)**2
|
||||
END IF
|
||||
END IF
|
||||
10 CONTINUE
|
||||
NORM = SCALE*SQRT(SSQ)
|
||||
END IF
|
||||
*
|
||||
DZNRM2 = NORM
|
||||
RETURN
|
||||
*
|
||||
* End of DZNRM2.
|
||||
*
|
||||
END
|
||||
118
lib/linalg/ilazlc.f
Normal file
118
lib/linalg/ilazlc.f
Normal file
@ -0,0 +1,118 @@
|
||||
*> \brief \b ILAZLC scans a matrix for its last non-zero column.
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
*> \htmlonly
|
||||
*> Download ILAZLC + dependencies
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ilazlc.f">
|
||||
*> [TGZ]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ilazlc.f">
|
||||
*> [ZIP]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ilazlc.f">
|
||||
*> [TXT]</a>
|
||||
*> \endhtmlonly
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* INTEGER FUNCTION ILAZLC( M, N, A, LDA )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER M, N, LDA
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* COMPLEX*16 A( LDA, * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> ILAZLC scans A for its last non-zero column.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] M
|
||||
*> \verbatim
|
||||
*> M is INTEGER
|
||||
*> The number of rows of the matrix A.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> The number of columns of the matrix A.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] A
|
||||
*> \verbatim
|
||||
*> A is COMPLEX*16 array, dimension (LDA,N)
|
||||
*> The m by n matrix A.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> The leading dimension of the array A. LDA >= max(1,M).
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date September 2012
|
||||
*
|
||||
*> \ingroup complex16OTHERauxiliary
|
||||
*
|
||||
* =====================================================================
|
||||
INTEGER FUNCTION ILAZLC( M, N, A, LDA )
|
||||
*
|
||||
* -- LAPACK auxiliary routine (version 3.4.2) --
|
||||
* -- 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 ..
|
||||
INTEGER M, N, LDA
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
COMPLEX*16 A( LDA, * )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
COMPLEX*16 ZERO
|
||||
PARAMETER ( ZERO = (0.0D+0, 0.0D+0) )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
INTEGER I
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* Quick test for the common case where one corner is non-zero.
|
||||
IF( N.EQ.0 ) THEN
|
||||
ILAZLC = N
|
||||
ELSE IF( A(1, N).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN
|
||||
ILAZLC = N
|
||||
ELSE
|
||||
* Now scan each column from the end, returning with the first non-zero.
|
||||
DO ILAZLC = N, 1, -1
|
||||
DO I = 1, M
|
||||
IF( A(I, ILAZLC).NE.ZERO ) RETURN
|
||||
END DO
|
||||
END DO
|
||||
END IF
|
||||
RETURN
|
||||
END
|
||||
121
lib/linalg/ilazlr.f
Normal file
121
lib/linalg/ilazlr.f
Normal file
@ -0,0 +1,121 @@
|
||||
*> \brief \b ILAZLR scans a matrix for its last non-zero row.
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
*> \htmlonly
|
||||
*> Download ILAZLR + dependencies
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ilazlr.f">
|
||||
*> [TGZ]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ilazlr.f">
|
||||
*> [ZIP]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ilazlr.f">
|
||||
*> [TXT]</a>
|
||||
*> \endhtmlonly
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* INTEGER FUNCTION ILAZLR( M, N, A, LDA )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER M, N, LDA
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* COMPLEX*16 A( LDA, * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> ILAZLR scans A for its last non-zero row.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] M
|
||||
*> \verbatim
|
||||
*> M is INTEGER
|
||||
*> The number of rows of the matrix A.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> The number of columns of the matrix A.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] A
|
||||
*> \verbatim
|
||||
*> A is COMPLEX*16 array, dimension (LDA,N)
|
||||
*> The m by n matrix A.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> The leading dimension of the array A. LDA >= max(1,M).
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date September 2012
|
||||
*
|
||||
*> \ingroup complex16OTHERauxiliary
|
||||
*
|
||||
* =====================================================================
|
||||
INTEGER FUNCTION ILAZLR( M, N, A, LDA )
|
||||
*
|
||||
* -- LAPACK auxiliary routine (version 3.4.2) --
|
||||
* -- 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 ..
|
||||
INTEGER M, N, LDA
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
COMPLEX*16 A( LDA, * )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
COMPLEX*16 ZERO
|
||||
PARAMETER ( ZERO = (0.0D+0, 0.0D+0) )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
INTEGER I, J
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* Quick test for the common case where one corner is non-zero.
|
||||
IF( M.EQ.0 ) THEN
|
||||
ILAZLR = M
|
||||
ELSE IF( A(M, 1).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN
|
||||
ILAZLR = M
|
||||
ELSE
|
||||
* Scan up each column tracking the last zero row seen.
|
||||
ILAZLR = 0
|
||||
DO J = 1, N
|
||||
I=M
|
||||
DO WHILE((A(MAX(I,1),J).EQ.ZERO).AND.(I.GE.1))
|
||||
I=I-1
|
||||
ENDDO
|
||||
ILAZLR = MAX( ILAZLR, I )
|
||||
END DO
|
||||
END IF
|
||||
RETURN
|
||||
END
|
||||
102
lib/linalg/zaxpy.f
Normal file
102
lib/linalg/zaxpy.f
Normal file
@ -0,0 +1,102 @@
|
||||
*> \brief \b ZAXPY
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE ZAXPY(N,ZA,ZX,INCX,ZY,INCY)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* COMPLEX*16 ZA
|
||||
* INTEGER INCX,INCY,N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* COMPLEX*16 ZX(*),ZY(*)
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> ZAXPY constant times a vector plus a vector.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup complex16_blas_level1
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> jack dongarra, 3/11/78.
|
||||
*> modified 12/3/93, array(1) declarations changed to array(*)
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
SUBROUTINE ZAXPY(N,ZA,ZX,INCX,ZY,INCY)
|
||||
*
|
||||
* -- Reference BLAS level1 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
COMPLEX*16 ZA
|
||||
INTEGER INCX,INCY,N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
COMPLEX*16 ZX(*),ZY(*)
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Local Scalars ..
|
||||
INTEGER I,IX,IY
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
DOUBLE PRECISION DCABS1
|
||||
EXTERNAL DCABS1
|
||||
* ..
|
||||
IF (N.LE.0) RETURN
|
||||
IF (DCABS1(ZA).EQ.0.0d0) RETURN
|
||||
IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN
|
||||
*
|
||||
* code for both increments equal to 1
|
||||
*
|
||||
DO I = 1,N
|
||||
ZY(I) = ZY(I) + ZA*ZX(I)
|
||||
END DO
|
||||
ELSE
|
||||
*
|
||||
* code for unequal increments or equal increments
|
||||
* not equal to 1
|
||||
*
|
||||
IX = 1
|
||||
IY = 1
|
||||
IF (INCX.LT.0) IX = (-N+1)*INCX + 1
|
||||
IF (INCY.LT.0) IY = (-N+1)*INCY + 1
|
||||
DO I = 1,N
|
||||
ZY(IY) = ZY(IY) + ZA*ZX(IX)
|
||||
IX = IX + INCX
|
||||
IY = IY + INCY
|
||||
END DO
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
END
|
||||
94
lib/linalg/zcopy.f
Normal file
94
lib/linalg/zcopy.f
Normal file
@ -0,0 +1,94 @@
|
||||
*> \brief \b ZCOPY
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE ZCOPY(N,ZX,INCX,ZY,INCY)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER INCX,INCY,N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* COMPLEX*16 ZX(*),ZY(*)
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> ZCOPY copies a vector, x, to a vector, y.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup complex16_blas_level1
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> jack dongarra, linpack, 4/11/78.
|
||||
*> modified 12/3/93, array(1) declarations changed to array(*)
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
SUBROUTINE ZCOPY(N,ZX,INCX,ZY,INCY)
|
||||
*
|
||||
* -- Reference BLAS level1 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER INCX,INCY,N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
COMPLEX*16 ZX(*),ZY(*)
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Local Scalars ..
|
||||
INTEGER I,IX,IY
|
||||
* ..
|
||||
IF (N.LE.0) RETURN
|
||||
IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN
|
||||
*
|
||||
* code for both increments equal to 1
|
||||
*
|
||||
DO I = 1,N
|
||||
ZY(I) = ZX(I)
|
||||
END DO
|
||||
ELSE
|
||||
*
|
||||
* code for unequal increments or equal increments
|
||||
* not equal to 1
|
||||
*
|
||||
IX = 1
|
||||
IY = 1
|
||||
IF (INCX.LT.0) IX = (-N+1)*INCX + 1
|
||||
IF (INCY.LT.0) IY = (-N+1)*INCY + 1
|
||||
DO I = 1,N
|
||||
ZY(IY) = ZX(IX)
|
||||
IX = IX + INCX
|
||||
IY = IY + INCY
|
||||
END DO
|
||||
END IF
|
||||
RETURN
|
||||
END
|
||||
489
lib/linalg/zgemm.f
Normal file
489
lib/linalg/zgemm.f
Normal file
@ -0,0 +1,489 @@
|
||||
*> \brief \b ZGEMM
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE ZGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* COMPLEX*16 ALPHA,BETA
|
||||
* INTEGER K,LDA,LDB,LDC,M,N
|
||||
* CHARACTER TRANSA,TRANSB
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* COMPLEX*16 A(LDA,*),B(LDB,*),C(LDC,*)
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> ZGEMM performs one of the matrix-matrix operations
|
||||
*>
|
||||
*> C := alpha*op( A )*op( B ) + beta*C,
|
||||
*>
|
||||
*> where op( X ) is one of
|
||||
*>
|
||||
*> op( X ) = X or op( X ) = X**T or op( X ) = X**H,
|
||||
*>
|
||||
*> alpha and beta are scalars, and A, B and C are matrices, with op( A )
|
||||
*> an m by k matrix, op( B ) a k by n matrix and C an m by n matrix.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] TRANSA
|
||||
*> \verbatim
|
||||
*> TRANSA is CHARACTER*1
|
||||
*> On entry, TRANSA specifies the form of op( A ) to be used in
|
||||
*> the matrix multiplication as follows:
|
||||
*>
|
||||
*> TRANSA = 'N' or 'n', op( A ) = A.
|
||||
*>
|
||||
*> TRANSA = 'T' or 't', op( A ) = A**T.
|
||||
*>
|
||||
*> TRANSA = 'C' or 'c', op( A ) = A**H.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] TRANSB
|
||||
*> \verbatim
|
||||
*> TRANSB is CHARACTER*1
|
||||
*> On entry, TRANSB specifies the form of op( B ) to be used in
|
||||
*> the matrix multiplication as follows:
|
||||
*>
|
||||
*> TRANSB = 'N' or 'n', op( B ) = B.
|
||||
*>
|
||||
*> TRANSB = 'T' or 't', op( B ) = B**T.
|
||||
*>
|
||||
*> TRANSB = 'C' or 'c', op( B ) = B**H.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] M
|
||||
*> \verbatim
|
||||
*> M is INTEGER
|
||||
*> On entry, M specifies the number of rows of the matrix
|
||||
*> op( A ) and of the matrix C. M must be at least zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> On entry, N specifies the number of columns of the matrix
|
||||
*> op( B ) and the number of columns of the matrix C. N must be
|
||||
*> at least zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] K
|
||||
*> \verbatim
|
||||
*> K is INTEGER
|
||||
*> On entry, K specifies the number of columns of the matrix
|
||||
*> op( A ) and the number of rows of the matrix op( B ). K must
|
||||
*> be at least zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] ALPHA
|
||||
*> \verbatim
|
||||
*> ALPHA is COMPLEX*16
|
||||
*> On entry, ALPHA specifies the scalar alpha.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] A
|
||||
*> \verbatim
|
||||
*> A is COMPLEX*16 array of DIMENSION ( LDA, ka ), where ka is
|
||||
*> k when TRANSA = 'N' or 'n', and is m otherwise.
|
||||
*> Before entry with TRANSA = 'N' or 'n', the leading m by k
|
||||
*> part of the array A must contain the matrix A, otherwise
|
||||
*> the leading k by m part of the array A must contain the
|
||||
*> matrix A.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> On entry, LDA specifies the first dimension of A as declared
|
||||
*> in the calling (sub) program. When TRANSA = 'N' or 'n' then
|
||||
*> LDA must be at least max( 1, m ), otherwise LDA must be at
|
||||
*> least max( 1, k ).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] B
|
||||
*> \verbatim
|
||||
*> B is COMPLEX*16 array of DIMENSION ( LDB, kb ), where kb is
|
||||
*> n when TRANSB = 'N' or 'n', and is k otherwise.
|
||||
*> Before entry with TRANSB = 'N' or 'n', the leading k by n
|
||||
*> part of the array B must contain the matrix B, otherwise
|
||||
*> the leading n by k part of the array B must contain the
|
||||
*> matrix B.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDB
|
||||
*> \verbatim
|
||||
*> LDB is INTEGER
|
||||
*> On entry, LDB specifies the first dimension of B as declared
|
||||
*> in the calling (sub) program. When TRANSB = 'N' or 'n' then
|
||||
*> LDB must be at least max( 1, k ), otherwise LDB must be at
|
||||
*> least max( 1, n ).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] BETA
|
||||
*> \verbatim
|
||||
*> BETA is COMPLEX*16
|
||||
*> On entry, BETA specifies the scalar beta. When BETA is
|
||||
*> supplied as zero then C need not be set on input.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] C
|
||||
*> \verbatim
|
||||
*> C is COMPLEX*16 array of DIMENSION ( LDC, n ).
|
||||
*> Before entry, the leading m by n part of the array C must
|
||||
*> contain the matrix C, except when beta is zero, in which
|
||||
*> case C need not be set on entry.
|
||||
*> On exit, the array C is overwritten by the m by n matrix
|
||||
*> ( alpha*op( A )*op( B ) + beta*C ).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDC
|
||||
*> \verbatim
|
||||
*> LDC is INTEGER
|
||||
*> On entry, LDC specifies the first dimension of C as declared
|
||||
*> in the calling (sub) program. LDC must be at least
|
||||
*> max( 1, m ).
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup complex16_blas_level3
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> Level 3 Blas routine.
|
||||
*>
|
||||
*> -- Written on 8-February-1989.
|
||||
*> Jack Dongarra, Argonne National Laboratory.
|
||||
*> Iain Duff, AERE Harwell.
|
||||
*> Jeremy Du Croz, Numerical Algorithms Group Ltd.
|
||||
*> Sven Hammarling, Numerical Algorithms Group Ltd.
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
SUBROUTINE ZGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
|
||||
*
|
||||
* -- Reference BLAS level3 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
COMPLEX*16 ALPHA,BETA
|
||||
INTEGER K,LDA,LDB,LDC,M,N
|
||||
CHARACTER TRANSA,TRANSB
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
COMPLEX*16 A(LDA,*),B(LDB,*),C(LDC,*)
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
EXTERNAL LSAME
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC DCONJG,MAX
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
COMPLEX*16 TEMP
|
||||
INTEGER I,INFO,J,L,NCOLA,NROWA,NROWB
|
||||
LOGICAL CONJA,CONJB,NOTA,NOTB
|
||||
* ..
|
||||
* .. Parameters ..
|
||||
COMPLEX*16 ONE
|
||||
PARAMETER (ONE= (1.0D+0,0.0D+0))
|
||||
COMPLEX*16 ZERO
|
||||
PARAMETER (ZERO= (0.0D+0,0.0D+0))
|
||||
* ..
|
||||
*
|
||||
* Set NOTA and NOTB as true if A and B respectively are not
|
||||
* conjugated or transposed, set CONJA and CONJB as true if A and
|
||||
* B respectively are to be transposed but not conjugated and set
|
||||
* NROWA, NCOLA and NROWB as the number of rows and columns of A
|
||||
* and the number of rows of B respectively.
|
||||
*
|
||||
NOTA = LSAME(TRANSA,'N')
|
||||
NOTB = LSAME(TRANSB,'N')
|
||||
CONJA = LSAME(TRANSA,'C')
|
||||
CONJB = LSAME(TRANSB,'C')
|
||||
IF (NOTA) THEN
|
||||
NROWA = M
|
||||
NCOLA = K
|
||||
ELSE
|
||||
NROWA = K
|
||||
NCOLA = M
|
||||
END IF
|
||||
IF (NOTB) THEN
|
||||
NROWB = K
|
||||
ELSE
|
||||
NROWB = N
|
||||
END IF
|
||||
*
|
||||
* Test the input parameters.
|
||||
*
|
||||
INFO = 0
|
||||
IF ((.NOT.NOTA) .AND. (.NOT.CONJA) .AND.
|
||||
+ (.NOT.LSAME(TRANSA,'T'))) THEN
|
||||
INFO = 1
|
||||
ELSE IF ((.NOT.NOTB) .AND. (.NOT.CONJB) .AND.
|
||||
+ (.NOT.LSAME(TRANSB,'T'))) THEN
|
||||
INFO = 2
|
||||
ELSE IF (M.LT.0) THEN
|
||||
INFO = 3
|
||||
ELSE IF (N.LT.0) THEN
|
||||
INFO = 4
|
||||
ELSE IF (K.LT.0) THEN
|
||||
INFO = 5
|
||||
ELSE IF (LDA.LT.MAX(1,NROWA)) THEN
|
||||
INFO = 8
|
||||
ELSE IF (LDB.LT.MAX(1,NROWB)) THEN
|
||||
INFO = 10
|
||||
ELSE IF (LDC.LT.MAX(1,M)) THEN
|
||||
INFO = 13
|
||||
END IF
|
||||
IF (INFO.NE.0) THEN
|
||||
CALL XERBLA('ZGEMM ',INFO)
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible.
|
||||
*
|
||||
IF ((M.EQ.0) .OR. (N.EQ.0) .OR.
|
||||
+ (((ALPHA.EQ.ZERO).OR. (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN
|
||||
*
|
||||
* And when alpha.eq.zero.
|
||||
*
|
||||
IF (ALPHA.EQ.ZERO) THEN
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
DO 20 J = 1,N
|
||||
DO 10 I = 1,M
|
||||
C(I,J) = ZERO
|
||||
10 CONTINUE
|
||||
20 CONTINUE
|
||||
ELSE
|
||||
DO 40 J = 1,N
|
||||
DO 30 I = 1,M
|
||||
C(I,J) = BETA*C(I,J)
|
||||
30 CONTINUE
|
||||
40 CONTINUE
|
||||
END IF
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Start the operations.
|
||||
*
|
||||
IF (NOTB) THEN
|
||||
IF (NOTA) THEN
|
||||
*
|
||||
* Form C := alpha*A*B + beta*C.
|
||||
*
|
||||
DO 90 J = 1,N
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
DO 50 I = 1,M
|
||||
C(I,J) = ZERO
|
||||
50 CONTINUE
|
||||
ELSE IF (BETA.NE.ONE) THEN
|
||||
DO 60 I = 1,M
|
||||
C(I,J) = BETA*C(I,J)
|
||||
60 CONTINUE
|
||||
END IF
|
||||
DO 80 L = 1,K
|
||||
IF (B(L,J).NE.ZERO) THEN
|
||||
TEMP = ALPHA*B(L,J)
|
||||
DO 70 I = 1,M
|
||||
C(I,J) = C(I,J) + TEMP*A(I,L)
|
||||
70 CONTINUE
|
||||
END IF
|
||||
80 CONTINUE
|
||||
90 CONTINUE
|
||||
ELSE IF (CONJA) THEN
|
||||
*
|
||||
* Form C := alpha*A**H*B + beta*C.
|
||||
*
|
||||
DO 120 J = 1,N
|
||||
DO 110 I = 1,M
|
||||
TEMP = ZERO
|
||||
DO 100 L = 1,K
|
||||
TEMP = TEMP + DCONJG(A(L,I))*B(L,J)
|
||||
100 CONTINUE
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
C(I,J) = ALPHA*TEMP
|
||||
ELSE
|
||||
C(I,J) = ALPHA*TEMP + BETA*C(I,J)
|
||||
END IF
|
||||
110 CONTINUE
|
||||
120 CONTINUE
|
||||
ELSE
|
||||
*
|
||||
* Form C := alpha*A**T*B + beta*C
|
||||
*
|
||||
DO 150 J = 1,N
|
||||
DO 140 I = 1,M
|
||||
TEMP = ZERO
|
||||
DO 130 L = 1,K
|
||||
TEMP = TEMP + A(L,I)*B(L,J)
|
||||
130 CONTINUE
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
C(I,J) = ALPHA*TEMP
|
||||
ELSE
|
||||
C(I,J) = ALPHA*TEMP + BETA*C(I,J)
|
||||
END IF
|
||||
140 CONTINUE
|
||||
150 CONTINUE
|
||||
END IF
|
||||
ELSE IF (NOTA) THEN
|
||||
IF (CONJB) THEN
|
||||
*
|
||||
* Form C := alpha*A*B**H + beta*C.
|
||||
*
|
||||
DO 200 J = 1,N
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
DO 160 I = 1,M
|
||||
C(I,J) = ZERO
|
||||
160 CONTINUE
|
||||
ELSE IF (BETA.NE.ONE) THEN
|
||||
DO 170 I = 1,M
|
||||
C(I,J) = BETA*C(I,J)
|
||||
170 CONTINUE
|
||||
END IF
|
||||
DO 190 L = 1,K
|
||||
IF (B(J,L).NE.ZERO) THEN
|
||||
TEMP = ALPHA*DCONJG(B(J,L))
|
||||
DO 180 I = 1,M
|
||||
C(I,J) = C(I,J) + TEMP*A(I,L)
|
||||
180 CONTINUE
|
||||
END IF
|
||||
190 CONTINUE
|
||||
200 CONTINUE
|
||||
ELSE
|
||||
*
|
||||
* Form C := alpha*A*B**T + beta*C
|
||||
*
|
||||
DO 250 J = 1,N
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
DO 210 I = 1,M
|
||||
C(I,J) = ZERO
|
||||
210 CONTINUE
|
||||
ELSE IF (BETA.NE.ONE) THEN
|
||||
DO 220 I = 1,M
|
||||
C(I,J) = BETA*C(I,J)
|
||||
220 CONTINUE
|
||||
END IF
|
||||
DO 240 L = 1,K
|
||||
IF (B(J,L).NE.ZERO) THEN
|
||||
TEMP = ALPHA*B(J,L)
|
||||
DO 230 I = 1,M
|
||||
C(I,J) = C(I,J) + TEMP*A(I,L)
|
||||
230 CONTINUE
|
||||
END IF
|
||||
240 CONTINUE
|
||||
250 CONTINUE
|
||||
END IF
|
||||
ELSE IF (CONJA) THEN
|
||||
IF (CONJB) THEN
|
||||
*
|
||||
* Form C := alpha*A**H*B**H + beta*C.
|
||||
*
|
||||
DO 280 J = 1,N
|
||||
DO 270 I = 1,M
|
||||
TEMP = ZERO
|
||||
DO 260 L = 1,K
|
||||
TEMP = TEMP + DCONJG(A(L,I))*DCONJG(B(J,L))
|
||||
260 CONTINUE
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
C(I,J) = ALPHA*TEMP
|
||||
ELSE
|
||||
C(I,J) = ALPHA*TEMP + BETA*C(I,J)
|
||||
END IF
|
||||
270 CONTINUE
|
||||
280 CONTINUE
|
||||
ELSE
|
||||
*
|
||||
* Form C := alpha*A**H*B**T + beta*C
|
||||
*
|
||||
DO 310 J = 1,N
|
||||
DO 300 I = 1,M
|
||||
TEMP = ZERO
|
||||
DO 290 L = 1,K
|
||||
TEMP = TEMP + DCONJG(A(L,I))*B(J,L)
|
||||
290 CONTINUE
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
C(I,J) = ALPHA*TEMP
|
||||
ELSE
|
||||
C(I,J) = ALPHA*TEMP + BETA*C(I,J)
|
||||
END IF
|
||||
300 CONTINUE
|
||||
310 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
IF (CONJB) THEN
|
||||
*
|
||||
* Form C := alpha*A**T*B**H + beta*C
|
||||
*
|
||||
DO 340 J = 1,N
|
||||
DO 330 I = 1,M
|
||||
TEMP = ZERO
|
||||
DO 320 L = 1,K
|
||||
TEMP = TEMP + A(L,I)*DCONJG(B(J,L))
|
||||
320 CONTINUE
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
C(I,J) = ALPHA*TEMP
|
||||
ELSE
|
||||
C(I,J) = ALPHA*TEMP + BETA*C(I,J)
|
||||
END IF
|
||||
330 CONTINUE
|
||||
340 CONTINUE
|
||||
ELSE
|
||||
*
|
||||
* Form C := alpha*A**T*B**T + beta*C
|
||||
*
|
||||
DO 370 J = 1,N
|
||||
DO 360 I = 1,M
|
||||
TEMP = ZERO
|
||||
DO 350 L = 1,K
|
||||
TEMP = TEMP + A(L,I)*B(J,L)
|
||||
350 CONTINUE
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
C(I,J) = ALPHA*TEMP
|
||||
ELSE
|
||||
C(I,J) = ALPHA*TEMP + BETA*C(I,J)
|
||||
END IF
|
||||
360 CONTINUE
|
||||
370 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of ZGEMM .
|
||||
*
|
||||
END
|
||||
354
lib/linalg/zgemv.f
Normal file
354
lib/linalg/zgemv.f
Normal file
@ -0,0 +1,354 @@
|
||||
*> \brief \b ZGEMV
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE ZGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* COMPLEX*16 ALPHA,BETA
|
||||
* INTEGER INCX,INCY,LDA,M,N
|
||||
* CHARACTER TRANS
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* COMPLEX*16 A(LDA,*),X(*),Y(*)
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> ZGEMV performs one of the matrix-vector operations
|
||||
*>
|
||||
*> y := alpha*A*x + beta*y, or y := alpha*A**T*x + beta*y, or
|
||||
*>
|
||||
*> y := alpha*A**H*x + beta*y,
|
||||
*>
|
||||
*> where alpha and beta are scalars, x and y are vectors and A is an
|
||||
*> m by n matrix.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] TRANS
|
||||
*> \verbatim
|
||||
*> TRANS is CHARACTER*1
|
||||
*> On entry, TRANS specifies the operation to be performed as
|
||||
*> follows:
|
||||
*>
|
||||
*> TRANS = 'N' or 'n' y := alpha*A*x + beta*y.
|
||||
*>
|
||||
*> TRANS = 'T' or 't' y := alpha*A**T*x + beta*y.
|
||||
*>
|
||||
*> TRANS = 'C' or 'c' y := alpha*A**H*x + beta*y.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] M
|
||||
*> \verbatim
|
||||
*> M is INTEGER
|
||||
*> On entry, M specifies the number of rows of the matrix A.
|
||||
*> M must be at least zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> On entry, N specifies the number of columns of the matrix A.
|
||||
*> N must be at least zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] ALPHA
|
||||
*> \verbatim
|
||||
*> ALPHA is COMPLEX*16
|
||||
*> On entry, ALPHA specifies the scalar alpha.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] A
|
||||
*> \verbatim
|
||||
*> A is COMPLEX*16 array of DIMENSION ( LDA, n ).
|
||||
*> Before entry, the leading m by n part of the array A must
|
||||
*> contain the matrix of coefficients.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> On entry, LDA specifies the first dimension of A as declared
|
||||
*> in the calling (sub) program. LDA must be at least
|
||||
*> max( 1, m ).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] X
|
||||
*> \verbatim
|
||||
*> X is COMPLEX*16 array of DIMENSION at least
|
||||
*> ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n'
|
||||
*> and at least
|
||||
*> ( 1 + ( m - 1 )*abs( INCX ) ) otherwise.
|
||||
*> Before entry, the incremented array X must contain the
|
||||
*> vector x.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] INCX
|
||||
*> \verbatim
|
||||
*> INCX is INTEGER
|
||||
*> On entry, INCX specifies the increment for the elements of
|
||||
*> X. INCX must not be zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] BETA
|
||||
*> \verbatim
|
||||
*> BETA is COMPLEX*16
|
||||
*> On entry, BETA specifies the scalar beta. When BETA is
|
||||
*> supplied as zero then Y need not be set on input.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] Y
|
||||
*> \verbatim
|
||||
*> Y is COMPLEX*16 array of DIMENSION at least
|
||||
*> ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n'
|
||||
*> and at least
|
||||
*> ( 1 + ( n - 1 )*abs( INCY ) ) otherwise.
|
||||
*> Before entry with BETA non-zero, the incremented array Y
|
||||
*> must contain the vector y. On exit, Y is overwritten by the
|
||||
*> updated vector y.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] INCY
|
||||
*> \verbatim
|
||||
*> INCY is INTEGER
|
||||
*> On entry, INCY specifies the increment for the elements of
|
||||
*> Y. INCY must not be zero.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup complex16_blas_level2
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> Level 2 Blas routine.
|
||||
*> The vector and matrix arguments are not referenced when N = 0, or M = 0
|
||||
*>
|
||||
*> -- Written on 22-October-1986.
|
||||
*> Jack Dongarra, Argonne National Lab.
|
||||
*> Jeremy Du Croz, Nag Central Office.
|
||||
*> Sven Hammarling, Nag Central Office.
|
||||
*> Richard Hanson, Sandia National Labs.
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
SUBROUTINE ZGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
|
||||
*
|
||||
* -- Reference BLAS level2 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
COMPLEX*16 ALPHA,BETA
|
||||
INTEGER INCX,INCY,LDA,M,N
|
||||
CHARACTER TRANS
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
COMPLEX*16 A(LDA,*),X(*),Y(*)
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
COMPLEX*16 ONE
|
||||
PARAMETER (ONE= (1.0D+0,0.0D+0))
|
||||
COMPLEX*16 ZERO
|
||||
PARAMETER (ZERO= (0.0D+0,0.0D+0))
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
COMPLEX*16 TEMP
|
||||
INTEGER I,INFO,IX,IY,J,JX,JY,KX,KY,LENX,LENY
|
||||
LOGICAL NOCONJ
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
EXTERNAL LSAME
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC DCONJG,MAX
|
||||
* ..
|
||||
*
|
||||
* Test the input parameters.
|
||||
*
|
||||
INFO = 0
|
||||
IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND.
|
||||
+ .NOT.LSAME(TRANS,'C')) THEN
|
||||
INFO = 1
|
||||
ELSE IF (M.LT.0) THEN
|
||||
INFO = 2
|
||||
ELSE IF (N.LT.0) THEN
|
||||
INFO = 3
|
||||
ELSE IF (LDA.LT.MAX(1,M)) THEN
|
||||
INFO = 6
|
||||
ELSE IF (INCX.EQ.0) THEN
|
||||
INFO = 8
|
||||
ELSE IF (INCY.EQ.0) THEN
|
||||
INFO = 11
|
||||
END IF
|
||||
IF (INFO.NE.0) THEN
|
||||
CALL XERBLA('ZGEMV ',INFO)
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible.
|
||||
*
|
||||
IF ((M.EQ.0) .OR. (N.EQ.0) .OR.
|
||||
+ ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN
|
||||
*
|
||||
NOCONJ = LSAME(TRANS,'T')
|
||||
*
|
||||
* Set LENX and LENY, the lengths of the vectors x and y, and set
|
||||
* up the start points in X and Y.
|
||||
*
|
||||
IF (LSAME(TRANS,'N')) THEN
|
||||
LENX = N
|
||||
LENY = M
|
||||
ELSE
|
||||
LENX = M
|
||||
LENY = N
|
||||
END IF
|
||||
IF (INCX.GT.0) THEN
|
||||
KX = 1
|
||||
ELSE
|
||||
KX = 1 - (LENX-1)*INCX
|
||||
END IF
|
||||
IF (INCY.GT.0) THEN
|
||||
KY = 1
|
||||
ELSE
|
||||
KY = 1 - (LENY-1)*INCY
|
||||
END IF
|
||||
*
|
||||
* Start the operations. In this version the elements of A are
|
||||
* accessed sequentially with one pass through A.
|
||||
*
|
||||
* First form y := beta*y.
|
||||
*
|
||||
IF (BETA.NE.ONE) THEN
|
||||
IF (INCY.EQ.1) THEN
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
DO 10 I = 1,LENY
|
||||
Y(I) = ZERO
|
||||
10 CONTINUE
|
||||
ELSE
|
||||
DO 20 I = 1,LENY
|
||||
Y(I) = BETA*Y(I)
|
||||
20 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
IY = KY
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
DO 30 I = 1,LENY
|
||||
Y(IY) = ZERO
|
||||
IY = IY + INCY
|
||||
30 CONTINUE
|
||||
ELSE
|
||||
DO 40 I = 1,LENY
|
||||
Y(IY) = BETA*Y(IY)
|
||||
IY = IY + INCY
|
||||
40 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
END IF
|
||||
IF (ALPHA.EQ.ZERO) RETURN
|
||||
IF (LSAME(TRANS,'N')) THEN
|
||||
*
|
||||
* Form y := alpha*A*x + y.
|
||||
*
|
||||
JX = KX
|
||||
IF (INCY.EQ.1) THEN
|
||||
DO 60 J = 1,N
|
||||
IF (X(JX).NE.ZERO) THEN
|
||||
TEMP = ALPHA*X(JX)
|
||||
DO 50 I = 1,M
|
||||
Y(I) = Y(I) + TEMP*A(I,J)
|
||||
50 CONTINUE
|
||||
END IF
|
||||
JX = JX + INCX
|
||||
60 CONTINUE
|
||||
ELSE
|
||||
DO 80 J = 1,N
|
||||
IF (X(JX).NE.ZERO) THEN
|
||||
TEMP = ALPHA*X(JX)
|
||||
IY = KY
|
||||
DO 70 I = 1,M
|
||||
Y(IY) = Y(IY) + TEMP*A(I,J)
|
||||
IY = IY + INCY
|
||||
70 CONTINUE
|
||||
END IF
|
||||
JX = JX + INCX
|
||||
80 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
*
|
||||
* Form y := alpha*A**T*x + y or y := alpha*A**H*x + y.
|
||||
*
|
||||
JY = KY
|
||||
IF (INCX.EQ.1) THEN
|
||||
DO 110 J = 1,N
|
||||
TEMP = ZERO
|
||||
IF (NOCONJ) THEN
|
||||
DO 90 I = 1,M
|
||||
TEMP = TEMP + A(I,J)*X(I)
|
||||
90 CONTINUE
|
||||
ELSE
|
||||
DO 100 I = 1,M
|
||||
TEMP = TEMP + DCONJG(A(I,J))*X(I)
|
||||
100 CONTINUE
|
||||
END IF
|
||||
Y(JY) = Y(JY) + ALPHA*TEMP
|
||||
JY = JY + INCY
|
||||
110 CONTINUE
|
||||
ELSE
|
||||
DO 140 J = 1,N
|
||||
TEMP = ZERO
|
||||
IX = KX
|
||||
IF (NOCONJ) THEN
|
||||
DO 120 I = 1,M
|
||||
TEMP = TEMP + A(I,J)*X(IX)
|
||||
IX = IX + INCX
|
||||
120 CONTINUE
|
||||
ELSE
|
||||
DO 130 I = 1,M
|
||||
TEMP = TEMP + DCONJG(A(I,J))*X(IX)
|
||||
IX = IX + INCX
|
||||
130 CONTINUE
|
||||
END IF
|
||||
Y(JY) = Y(JY) + ALPHA*TEMP
|
||||
JY = JY + INCY
|
||||
140 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of ZGEMV .
|
||||
*
|
||||
END
|
||||
227
lib/linalg/zgerc.f
Normal file
227
lib/linalg/zgerc.f
Normal file
@ -0,0 +1,227 @@
|
||||
*> \brief \b ZGERC
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE ZGERC(M,N,ALPHA,X,INCX,Y,INCY,A,LDA)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* COMPLEX*16 ALPHA
|
||||
* INTEGER INCX,INCY,LDA,M,N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* COMPLEX*16 A(LDA,*),X(*),Y(*)
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> ZGERC performs the rank 1 operation
|
||||
*>
|
||||
*> A := alpha*x*y**H + A,
|
||||
*>
|
||||
*> where alpha is a scalar, x is an m element vector, y is an n element
|
||||
*> vector and A is an m by n matrix.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] M
|
||||
*> \verbatim
|
||||
*> M is INTEGER
|
||||
*> On entry, M specifies the number of rows of the matrix A.
|
||||
*> M must be at least zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> On entry, N specifies the number of columns of the matrix A.
|
||||
*> N must be at least zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] ALPHA
|
||||
*> \verbatim
|
||||
*> ALPHA is COMPLEX*16
|
||||
*> On entry, ALPHA specifies the scalar alpha.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] X
|
||||
*> \verbatim
|
||||
*> X is COMPLEX*16 array of dimension at least
|
||||
*> ( 1 + ( m - 1 )*abs( INCX ) ).
|
||||
*> Before entry, the incremented array X must contain the m
|
||||
*> element vector x.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] INCX
|
||||
*> \verbatim
|
||||
*> INCX is INTEGER
|
||||
*> On entry, INCX specifies the increment for the elements of
|
||||
*> X. INCX must not be zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] Y
|
||||
*> \verbatim
|
||||
*> Y is COMPLEX*16 array of dimension at least
|
||||
*> ( 1 + ( n - 1 )*abs( INCY ) ).
|
||||
*> Before entry, the incremented array Y must contain the n
|
||||
*> element vector y.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] INCY
|
||||
*> \verbatim
|
||||
*> INCY is INTEGER
|
||||
*> On entry, INCY specifies the increment for the elements of
|
||||
*> Y. INCY must not be zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] A
|
||||
*> \verbatim
|
||||
*> A is COMPLEX*16 array of DIMENSION ( LDA, n ).
|
||||
*> Before entry, the leading m by n part of the array A must
|
||||
*> contain the matrix of coefficients. On exit, A is
|
||||
*> overwritten by the updated matrix.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> On entry, LDA specifies the first dimension of A as declared
|
||||
*> in the calling (sub) program. LDA must be at least
|
||||
*> max( 1, m ).
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup complex16_blas_level2
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> Level 2 Blas routine.
|
||||
*>
|
||||
*> -- Written on 22-October-1986.
|
||||
*> Jack Dongarra, Argonne National Lab.
|
||||
*> Jeremy Du Croz, Nag Central Office.
|
||||
*> Sven Hammarling, Nag Central Office.
|
||||
*> Richard Hanson, Sandia National Labs.
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
SUBROUTINE ZGERC(M,N,ALPHA,X,INCX,Y,INCY,A,LDA)
|
||||
*
|
||||
* -- Reference BLAS level2 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
COMPLEX*16 ALPHA
|
||||
INTEGER INCX,INCY,LDA,M,N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
COMPLEX*16 A(LDA,*),X(*),Y(*)
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
COMPLEX*16 ZERO
|
||||
PARAMETER (ZERO= (0.0D+0,0.0D+0))
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
COMPLEX*16 TEMP
|
||||
INTEGER I,INFO,IX,J,JY,KX
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC DCONJG,MAX
|
||||
* ..
|
||||
*
|
||||
* Test the input parameters.
|
||||
*
|
||||
INFO = 0
|
||||
IF (M.LT.0) THEN
|
||||
INFO = 1
|
||||
ELSE IF (N.LT.0) THEN
|
||||
INFO = 2
|
||||
ELSE IF (INCX.EQ.0) THEN
|
||||
INFO = 5
|
||||
ELSE IF (INCY.EQ.0) THEN
|
||||
INFO = 7
|
||||
ELSE IF (LDA.LT.MAX(1,M)) THEN
|
||||
INFO = 9
|
||||
END IF
|
||||
IF (INFO.NE.0) THEN
|
||||
CALL XERBLA('ZGERC ',INFO)
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible.
|
||||
*
|
||||
IF ((M.EQ.0) .OR. (N.EQ.0) .OR. (ALPHA.EQ.ZERO)) RETURN
|
||||
*
|
||||
* Start the operations. In this version the elements of A are
|
||||
* accessed sequentially with one pass through A.
|
||||
*
|
||||
IF (INCY.GT.0) THEN
|
||||
JY = 1
|
||||
ELSE
|
||||
JY = 1 - (N-1)*INCY
|
||||
END IF
|
||||
IF (INCX.EQ.1) THEN
|
||||
DO 20 J = 1,N
|
||||
IF (Y(JY).NE.ZERO) THEN
|
||||
TEMP = ALPHA*DCONJG(Y(JY))
|
||||
DO 10 I = 1,M
|
||||
A(I,J) = A(I,J) + X(I)*TEMP
|
||||
10 CONTINUE
|
||||
END IF
|
||||
JY = JY + INCY
|
||||
20 CONTINUE
|
||||
ELSE
|
||||
IF (INCX.GT.0) THEN
|
||||
KX = 1
|
||||
ELSE
|
||||
KX = 1 - (M-1)*INCX
|
||||
END IF
|
||||
DO 40 J = 1,N
|
||||
IF (Y(JY).NE.ZERO) THEN
|
||||
TEMP = ALPHA*DCONJG(Y(JY))
|
||||
IX = KX
|
||||
DO 30 I = 1,M
|
||||
A(I,J) = A(I,J) + X(IX)*TEMP
|
||||
IX = IX + INCX
|
||||
30 CONTINUE
|
||||
END IF
|
||||
JY = JY + INCY
|
||||
40 CONTINUE
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of ZGERC .
|
||||
*
|
||||
END
|
||||
298
lib/linalg/zheev.f
Normal file
298
lib/linalg/zheev.f
Normal file
@ -0,0 +1,298 @@
|
||||
*> \brief <b> ZHEEV computes the eigenvalues and, optionally, the left and/or right eigenvectors for HE matrices</b>
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
*> \htmlonly
|
||||
*> Download ZHEEV + dependencies
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zheev.f">
|
||||
*> [TGZ]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zheev.f">
|
||||
*> [ZIP]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zheev.f">
|
||||
*> [TXT]</a>
|
||||
*> \endhtmlonly
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE ZHEEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, RWORK,
|
||||
* INFO )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* CHARACTER JOBZ, UPLO
|
||||
* INTEGER INFO, LDA, LWORK, N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* DOUBLE PRECISION RWORK( * ), W( * )
|
||||
* COMPLEX*16 A( LDA, * ), WORK( * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> ZHEEV computes all eigenvalues and, optionally, eigenvectors of a
|
||||
*> complex Hermitian matrix A.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] JOBZ
|
||||
*> \verbatim
|
||||
*> JOBZ is CHARACTER*1
|
||||
*> = 'N': Compute eigenvalues only;
|
||||
*> = 'V': Compute eigenvalues and eigenvectors.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] UPLO
|
||||
*> \verbatim
|
||||
*> UPLO is CHARACTER*1
|
||||
*> = 'U': Upper triangle of A is stored;
|
||||
*> = 'L': Lower triangle of A is stored.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> The order of the matrix A. N >= 0.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] A
|
||||
*> \verbatim
|
||||
*> A is COMPLEX*16 array, dimension (LDA, N)
|
||||
*> On entry, the Hermitian matrix A. If UPLO = 'U', the
|
||||
*> leading N-by-N upper triangular part of A contains the
|
||||
*> upper triangular part of the matrix A. If UPLO = 'L',
|
||||
*> the leading N-by-N lower triangular part of A contains
|
||||
*> the lower triangular part of the matrix A.
|
||||
*> On exit, if JOBZ = 'V', then if INFO = 0, A contains the
|
||||
*> orthonormal eigenvectors of the matrix A.
|
||||
*> If JOBZ = 'N', then on exit the lower triangle (if UPLO='L')
|
||||
*> or the upper triangle (if UPLO='U') of A, including the
|
||||
*> diagonal, is destroyed.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> The leading dimension of the array A. LDA >= max(1,N).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] W
|
||||
*> \verbatim
|
||||
*> W is DOUBLE PRECISION array, dimension (N)
|
||||
*> If INFO = 0, the eigenvalues in ascending order.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] WORK
|
||||
*> \verbatim
|
||||
*> WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
|
||||
*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LWORK
|
||||
*> \verbatim
|
||||
*> LWORK is INTEGER
|
||||
*> The length of the array WORK. LWORK >= max(1,2*N-1).
|
||||
*> For optimal efficiency, LWORK >= (NB+1)*N,
|
||||
*> where NB is the blocksize for ZHETRD returned by ILAENV.
|
||||
*>
|
||||
*> If LWORK = -1, then a workspace query is assumed; the routine
|
||||
*> only calculates the optimal size of the WORK array, returns
|
||||
*> this value as the first entry of the WORK array, and no error
|
||||
*> message related to LWORK is issued by XERBLA.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] RWORK
|
||||
*> \verbatim
|
||||
*> RWORK is DOUBLE PRECISION array, dimension (max(1, 3*N-2))
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] INFO
|
||||
*> \verbatim
|
||||
*> INFO is INTEGER
|
||||
*> = 0: successful exit
|
||||
*> < 0: if INFO = -i, the i-th argument had an illegal value
|
||||
*> > 0: if INFO = i, the algorithm failed to converge; i
|
||||
*> off-diagonal elements of an intermediate tridiagonal
|
||||
*> form did not converge to zero.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup complex16HEeigen
|
||||
*
|
||||
* =====================================================================
|
||||
SUBROUTINE ZHEEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, RWORK,
|
||||
$ INFO )
|
||||
*
|
||||
* -- LAPACK driver routine (version 3.4.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
CHARACTER JOBZ, UPLO
|
||||
INTEGER INFO, LDA, LWORK, N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION RWORK( * ), W( * )
|
||||
COMPLEX*16 A( LDA, * ), WORK( * )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
DOUBLE PRECISION ZERO, ONE
|
||||
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
|
||||
COMPLEX*16 CONE
|
||||
PARAMETER ( CONE = ( 1.0D0, 0.0D0 ) )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
LOGICAL LOWER, LQUERY, WANTZ
|
||||
INTEGER IINFO, IMAX, INDE, INDTAU, INDWRK, ISCALE,
|
||||
$ LLWORK, LWKOPT, NB
|
||||
DOUBLE PRECISION ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA,
|
||||
$ SMLNUM
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
INTEGER ILAENV
|
||||
DOUBLE PRECISION DLAMCH, ZLANHE
|
||||
EXTERNAL LSAME, ILAENV, DLAMCH, ZLANHE
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL DSCAL, DSTERF, XERBLA, ZHETRD, ZLASCL, ZSTEQR,
|
||||
$ ZUNGTR
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC MAX, SQRT
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* Test the input parameters.
|
||||
*
|
||||
WANTZ = LSAME( JOBZ, 'V' )
|
||||
LOWER = LSAME( UPLO, 'L' )
|
||||
LQUERY = ( LWORK.EQ.-1 )
|
||||
*
|
||||
INFO = 0
|
||||
IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
|
||||
INFO = -1
|
||||
ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN
|
||||
INFO = -2
|
||||
ELSE IF( N.LT.0 ) THEN
|
||||
INFO = -3
|
||||
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
|
||||
INFO = -5
|
||||
END IF
|
||||
*
|
||||
IF( INFO.EQ.0 ) THEN
|
||||
NB = ILAENV( 1, 'ZHETRD', UPLO, N, -1, -1, -1 )
|
||||
LWKOPT = MAX( 1, ( NB+1 )*N )
|
||||
WORK( 1 ) = LWKOPT
|
||||
*
|
||||
IF( LWORK.LT.MAX( 1, 2*N-1 ) .AND. .NOT.LQUERY )
|
||||
$ INFO = -8
|
||||
END IF
|
||||
*
|
||||
IF( INFO.NE.0 ) THEN
|
||||
CALL XERBLA( 'ZHEEV ', -INFO )
|
||||
RETURN
|
||||
ELSE IF( LQUERY ) THEN
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible
|
||||
*
|
||||
IF( N.EQ.0 ) THEN
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
IF( N.EQ.1 ) THEN
|
||||
W( 1 ) = A( 1, 1 )
|
||||
WORK( 1 ) = 1
|
||||
IF( WANTZ )
|
||||
$ A( 1, 1 ) = CONE
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Get machine constants.
|
||||
*
|
||||
SAFMIN = DLAMCH( 'Safe minimum' )
|
||||
EPS = DLAMCH( 'Precision' )
|
||||
SMLNUM = SAFMIN / EPS
|
||||
BIGNUM = ONE / SMLNUM
|
||||
RMIN = SQRT( SMLNUM )
|
||||
RMAX = SQRT( BIGNUM )
|
||||
*
|
||||
* Scale matrix to allowable range, if necessary.
|
||||
*
|
||||
ANRM = ZLANHE( 'M', UPLO, N, A, LDA, RWORK )
|
||||
ISCALE = 0
|
||||
IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN
|
||||
ISCALE = 1
|
||||
SIGMA = RMIN / ANRM
|
||||
ELSE IF( ANRM.GT.RMAX ) THEN
|
||||
ISCALE = 1
|
||||
SIGMA = RMAX / ANRM
|
||||
END IF
|
||||
IF( ISCALE.EQ.1 )
|
||||
$ CALL ZLASCL( UPLO, 0, 0, ONE, SIGMA, N, N, A, LDA, INFO )
|
||||
*
|
||||
* Call ZHETRD to reduce Hermitian matrix to tridiagonal form.
|
||||
*
|
||||
INDE = 1
|
||||
INDTAU = 1
|
||||
INDWRK = INDTAU + N
|
||||
LLWORK = LWORK - INDWRK + 1
|
||||
CALL ZHETRD( UPLO, N, A, LDA, W, RWORK( INDE ), WORK( INDTAU ),
|
||||
$ WORK( INDWRK ), LLWORK, IINFO )
|
||||
*
|
||||
* For eigenvalues only, call DSTERF. For eigenvectors, first call
|
||||
* ZUNGTR to generate the unitary matrix, then call ZSTEQR.
|
||||
*
|
||||
IF( .NOT.WANTZ ) THEN
|
||||
CALL DSTERF( N, W, RWORK( INDE ), INFO )
|
||||
ELSE
|
||||
CALL ZUNGTR( UPLO, N, A, LDA, WORK( INDTAU ), WORK( INDWRK ),
|
||||
$ LLWORK, IINFO )
|
||||
INDWRK = INDE + N
|
||||
CALL ZSTEQR( JOBZ, N, W, RWORK( INDE ), A, LDA,
|
||||
$ RWORK( INDWRK ), INFO )
|
||||
END IF
|
||||
*
|
||||
* If matrix was scaled, then rescale eigenvalues appropriately.
|
||||
*
|
||||
IF( ISCALE.EQ.1 ) THEN
|
||||
IF( INFO.EQ.0 ) THEN
|
||||
IMAX = N
|
||||
ELSE
|
||||
IMAX = INFO - 1
|
||||
END IF
|
||||
CALL DSCAL( IMAX, ONE / SIGMA, W, 1 )
|
||||
END IF
|
||||
*
|
||||
* Set WORK(1) to optimal complex workspace size.
|
||||
*
|
||||
WORK( 1 ) = LWKOPT
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of ZHEEV
|
||||
*
|
||||
END
|
||||
337
lib/linalg/zhemv.f
Normal file
337
lib/linalg/zhemv.f
Normal file
@ -0,0 +1,337 @@
|
||||
*> \brief \b ZHEMV
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE ZHEMV(UPLO,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* COMPLEX*16 ALPHA,BETA
|
||||
* INTEGER INCX,INCY,LDA,N
|
||||
* CHARACTER UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* COMPLEX*16 A(LDA,*),X(*),Y(*)
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> ZHEMV performs the matrix-vector operation
|
||||
*>
|
||||
*> y := alpha*A*x + beta*y,
|
||||
*>
|
||||
*> where alpha and beta are scalars, x and y are n element vectors and
|
||||
*> A is an n by n hermitian matrix.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] UPLO
|
||||
*> \verbatim
|
||||
*> UPLO is CHARACTER*1
|
||||
*> On entry, UPLO specifies whether the upper or lower
|
||||
*> triangular part of the array A is to be referenced as
|
||||
*> follows:
|
||||
*>
|
||||
*> UPLO = 'U' or 'u' Only the upper triangular part of A
|
||||
*> is to be referenced.
|
||||
*>
|
||||
*> UPLO = 'L' or 'l' Only the lower triangular part of A
|
||||
*> is to be referenced.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> On entry, N specifies the order of the matrix A.
|
||||
*> N must be at least zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] ALPHA
|
||||
*> \verbatim
|
||||
*> ALPHA is COMPLEX*16
|
||||
*> On entry, ALPHA specifies the scalar alpha.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] A
|
||||
*> \verbatim
|
||||
*> A is COMPLEX*16 array of DIMENSION ( LDA, n ).
|
||||
*> Before entry with UPLO = 'U' or 'u', the leading n by n
|
||||
*> upper triangular part of the array A must contain the upper
|
||||
*> triangular part of the hermitian matrix and the strictly
|
||||
*> lower triangular part of A is not referenced.
|
||||
*> Before entry with UPLO = 'L' or 'l', the leading n by n
|
||||
*> lower triangular part of the array A must contain the lower
|
||||
*> triangular part of the hermitian matrix and the strictly
|
||||
*> upper triangular part of A is not referenced.
|
||||
*> Note that the imaginary parts of the diagonal elements need
|
||||
*> not be set and are assumed to be zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> On entry, LDA specifies the first dimension of A as declared
|
||||
*> in the calling (sub) program. LDA must be at least
|
||||
*> max( 1, n ).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] X
|
||||
*> \verbatim
|
||||
*> X is COMPLEX*16 array of dimension at least
|
||||
*> ( 1 + ( n - 1 )*abs( INCX ) ).
|
||||
*> Before entry, the incremented array X must contain the n
|
||||
*> element vector x.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] INCX
|
||||
*> \verbatim
|
||||
*> INCX is INTEGER
|
||||
*> On entry, INCX specifies the increment for the elements of
|
||||
*> X. INCX must not be zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] BETA
|
||||
*> \verbatim
|
||||
*> BETA is COMPLEX*16
|
||||
*> On entry, BETA specifies the scalar beta. When BETA is
|
||||
*> supplied as zero then Y need not be set on input.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] Y
|
||||
*> \verbatim
|
||||
*> Y is COMPLEX*16 array of dimension at least
|
||||
*> ( 1 + ( n - 1 )*abs( INCY ) ).
|
||||
*> Before entry, the incremented array Y must contain the n
|
||||
*> element vector y. On exit, Y is overwritten by the updated
|
||||
*> vector y.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] INCY
|
||||
*> \verbatim
|
||||
*> INCY is INTEGER
|
||||
*> On entry, INCY specifies the increment for the elements of
|
||||
*> Y. INCY must not be zero.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup complex16_blas_level2
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> Level 2 Blas routine.
|
||||
*> The vector and matrix arguments are not referenced when N = 0, or M = 0
|
||||
*>
|
||||
*> -- Written on 22-October-1986.
|
||||
*> Jack Dongarra, Argonne National Lab.
|
||||
*> Jeremy Du Croz, Nag Central Office.
|
||||
*> Sven Hammarling, Nag Central Office.
|
||||
*> Richard Hanson, Sandia National Labs.
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
SUBROUTINE ZHEMV(UPLO,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
|
||||
*
|
||||
* -- Reference BLAS level2 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
COMPLEX*16 ALPHA,BETA
|
||||
INTEGER INCX,INCY,LDA,N
|
||||
CHARACTER UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
COMPLEX*16 A(LDA,*),X(*),Y(*)
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
COMPLEX*16 ONE
|
||||
PARAMETER (ONE= (1.0D+0,0.0D+0))
|
||||
COMPLEX*16 ZERO
|
||||
PARAMETER (ZERO= (0.0D+0,0.0D+0))
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
COMPLEX*16 TEMP1,TEMP2
|
||||
INTEGER I,INFO,IX,IY,J,JX,JY,KX,KY
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
EXTERNAL LSAME
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC DBLE,DCONJG,MAX
|
||||
* ..
|
||||
*
|
||||
* Test the input parameters.
|
||||
*
|
||||
INFO = 0
|
||||
IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
|
||||
INFO = 1
|
||||
ELSE IF (N.LT.0) THEN
|
||||
INFO = 2
|
||||
ELSE IF (LDA.LT.MAX(1,N)) THEN
|
||||
INFO = 5
|
||||
ELSE IF (INCX.EQ.0) THEN
|
||||
INFO = 7
|
||||
ELSE IF (INCY.EQ.0) THEN
|
||||
INFO = 10
|
||||
END IF
|
||||
IF (INFO.NE.0) THEN
|
||||
CALL XERBLA('ZHEMV ',INFO)
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible.
|
||||
*
|
||||
IF ((N.EQ.0) .OR. ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN
|
||||
*
|
||||
* Set up the start points in X and Y.
|
||||
*
|
||||
IF (INCX.GT.0) THEN
|
||||
KX = 1
|
||||
ELSE
|
||||
KX = 1 - (N-1)*INCX
|
||||
END IF
|
||||
IF (INCY.GT.0) THEN
|
||||
KY = 1
|
||||
ELSE
|
||||
KY = 1 - (N-1)*INCY
|
||||
END IF
|
||||
*
|
||||
* Start the operations. In this version the elements of A are
|
||||
* accessed sequentially with one pass through the triangular part
|
||||
* of A.
|
||||
*
|
||||
* First form y := beta*y.
|
||||
*
|
||||
IF (BETA.NE.ONE) THEN
|
||||
IF (INCY.EQ.1) THEN
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
DO 10 I = 1,N
|
||||
Y(I) = ZERO
|
||||
10 CONTINUE
|
||||
ELSE
|
||||
DO 20 I = 1,N
|
||||
Y(I) = BETA*Y(I)
|
||||
20 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
IY = KY
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
DO 30 I = 1,N
|
||||
Y(IY) = ZERO
|
||||
IY = IY + INCY
|
||||
30 CONTINUE
|
||||
ELSE
|
||||
DO 40 I = 1,N
|
||||
Y(IY) = BETA*Y(IY)
|
||||
IY = IY + INCY
|
||||
40 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
END IF
|
||||
IF (ALPHA.EQ.ZERO) RETURN
|
||||
IF (LSAME(UPLO,'U')) THEN
|
||||
*
|
||||
* Form y when A is stored in upper triangle.
|
||||
*
|
||||
IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
|
||||
DO 60 J = 1,N
|
||||
TEMP1 = ALPHA*X(J)
|
||||
TEMP2 = ZERO
|
||||
DO 50 I = 1,J - 1
|
||||
Y(I) = Y(I) + TEMP1*A(I,J)
|
||||
TEMP2 = TEMP2 + DCONJG(A(I,J))*X(I)
|
||||
50 CONTINUE
|
||||
Y(J) = Y(J) + TEMP1*DBLE(A(J,J)) + ALPHA*TEMP2
|
||||
60 CONTINUE
|
||||
ELSE
|
||||
JX = KX
|
||||
JY = KY
|
||||
DO 80 J = 1,N
|
||||
TEMP1 = ALPHA*X(JX)
|
||||
TEMP2 = ZERO
|
||||
IX = KX
|
||||
IY = KY
|
||||
DO 70 I = 1,J - 1
|
||||
Y(IY) = Y(IY) + TEMP1*A(I,J)
|
||||
TEMP2 = TEMP2 + DCONJG(A(I,J))*X(IX)
|
||||
IX = IX + INCX
|
||||
IY = IY + INCY
|
||||
70 CONTINUE
|
||||
Y(JY) = Y(JY) + TEMP1*DBLE(A(J,J)) + ALPHA*TEMP2
|
||||
JX = JX + INCX
|
||||
JY = JY + INCY
|
||||
80 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
*
|
||||
* Form y when A is stored in lower triangle.
|
||||
*
|
||||
IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
|
||||
DO 100 J = 1,N
|
||||
TEMP1 = ALPHA*X(J)
|
||||
TEMP2 = ZERO
|
||||
Y(J) = Y(J) + TEMP1*DBLE(A(J,J))
|
||||
DO 90 I = J + 1,N
|
||||
Y(I) = Y(I) + TEMP1*A(I,J)
|
||||
TEMP2 = TEMP2 + DCONJG(A(I,J))*X(I)
|
||||
90 CONTINUE
|
||||
Y(J) = Y(J) + ALPHA*TEMP2
|
||||
100 CONTINUE
|
||||
ELSE
|
||||
JX = KX
|
||||
JY = KY
|
||||
DO 120 J = 1,N
|
||||
TEMP1 = ALPHA*X(JX)
|
||||
TEMP2 = ZERO
|
||||
Y(JY) = Y(JY) + TEMP1*DBLE(A(J,J))
|
||||
IX = JX
|
||||
IY = JY
|
||||
DO 110 I = J + 1,N
|
||||
IX = IX + INCX
|
||||
IY = IY + INCY
|
||||
Y(IY) = Y(IY) + TEMP1*A(I,J)
|
||||
TEMP2 = TEMP2 + DCONJG(A(I,J))*X(IX)
|
||||
110 CONTINUE
|
||||
Y(JY) = Y(JY) + ALPHA*TEMP2
|
||||
JX = JX + INCX
|
||||
JY = JY + INCY
|
||||
120 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of ZHEMV .
|
||||
*
|
||||
END
|
||||
317
lib/linalg/zher2.f
Normal file
317
lib/linalg/zher2.f
Normal file
@ -0,0 +1,317 @@
|
||||
*> \brief \b ZHER2
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE ZHER2(UPLO,N,ALPHA,X,INCX,Y,INCY,A,LDA)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* COMPLEX*16 ALPHA
|
||||
* INTEGER INCX,INCY,LDA,N
|
||||
* CHARACTER UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* COMPLEX*16 A(LDA,*),X(*),Y(*)
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> ZHER2 performs the hermitian rank 2 operation
|
||||
*>
|
||||
*> A := alpha*x*y**H + conjg( alpha )*y*x**H + A,
|
||||
*>
|
||||
*> where alpha is a scalar, x and y are n element vectors and A is an n
|
||||
*> by n hermitian matrix.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] UPLO
|
||||
*> \verbatim
|
||||
*> UPLO is CHARACTER*1
|
||||
*> On entry, UPLO specifies whether the upper or lower
|
||||
*> triangular part of the array A is to be referenced as
|
||||
*> follows:
|
||||
*>
|
||||
*> UPLO = 'U' or 'u' Only the upper triangular part of A
|
||||
*> is to be referenced.
|
||||
*>
|
||||
*> UPLO = 'L' or 'l' Only the lower triangular part of A
|
||||
*> is to be referenced.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> On entry, N specifies the order of the matrix A.
|
||||
*> N must be at least zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] ALPHA
|
||||
*> \verbatim
|
||||
*> ALPHA is COMPLEX*16
|
||||
*> On entry, ALPHA specifies the scalar alpha.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] X
|
||||
*> \verbatim
|
||||
*> X is COMPLEX*16 array of dimension at least
|
||||
*> ( 1 + ( n - 1 )*abs( INCX ) ).
|
||||
*> Before entry, the incremented array X must contain the n
|
||||
*> element vector x.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] INCX
|
||||
*> \verbatim
|
||||
*> INCX is INTEGER
|
||||
*> On entry, INCX specifies the increment for the elements of
|
||||
*> X. INCX must not be zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] Y
|
||||
*> \verbatim
|
||||
*> Y is COMPLEX*16 array of dimension at least
|
||||
*> ( 1 + ( n - 1 )*abs( INCY ) ).
|
||||
*> Before entry, the incremented array Y must contain the n
|
||||
*> element vector y.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] INCY
|
||||
*> \verbatim
|
||||
*> INCY is INTEGER
|
||||
*> On entry, INCY specifies the increment for the elements of
|
||||
*> Y. INCY must not be zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] A
|
||||
*> \verbatim
|
||||
*> A is COMPLEX*16 array of DIMENSION ( LDA, n ).
|
||||
*> Before entry with UPLO = 'U' or 'u', the leading n by n
|
||||
*> upper triangular part of the array A must contain the upper
|
||||
*> triangular part of the hermitian matrix and the strictly
|
||||
*> lower triangular part of A is not referenced. On exit, the
|
||||
*> upper triangular part of the array A is overwritten by the
|
||||
*> upper triangular part of the updated matrix.
|
||||
*> Before entry with UPLO = 'L' or 'l', the leading n by n
|
||||
*> lower triangular part of the array A must contain the lower
|
||||
*> triangular part of the hermitian matrix and the strictly
|
||||
*> upper triangular part of A is not referenced. On exit, the
|
||||
*> lower triangular part of the array A is overwritten by the
|
||||
*> lower triangular part of the updated matrix.
|
||||
*> Note that the imaginary parts of the diagonal elements need
|
||||
*> not be set, they are assumed to be zero, and on exit they
|
||||
*> are set to zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> On entry, LDA specifies the first dimension of A as declared
|
||||
*> in the calling (sub) program. LDA must be at least
|
||||
*> max( 1, n ).
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup complex16_blas_level2
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> Level 2 Blas routine.
|
||||
*>
|
||||
*> -- Written on 22-October-1986.
|
||||
*> Jack Dongarra, Argonne National Lab.
|
||||
*> Jeremy Du Croz, Nag Central Office.
|
||||
*> Sven Hammarling, Nag Central Office.
|
||||
*> Richard Hanson, Sandia National Labs.
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
SUBROUTINE ZHER2(UPLO,N,ALPHA,X,INCX,Y,INCY,A,LDA)
|
||||
*
|
||||
* -- Reference BLAS level2 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
COMPLEX*16 ALPHA
|
||||
INTEGER INCX,INCY,LDA,N
|
||||
CHARACTER UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
COMPLEX*16 A(LDA,*),X(*),Y(*)
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
COMPLEX*16 ZERO
|
||||
PARAMETER (ZERO= (0.0D+0,0.0D+0))
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
COMPLEX*16 TEMP1,TEMP2
|
||||
INTEGER I,INFO,IX,IY,J,JX,JY,KX,KY
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
EXTERNAL LSAME
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC DBLE,DCONJG,MAX
|
||||
* ..
|
||||
*
|
||||
* Test the input parameters.
|
||||
*
|
||||
INFO = 0
|
||||
IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
|
||||
INFO = 1
|
||||
ELSE IF (N.LT.0) THEN
|
||||
INFO = 2
|
||||
ELSE IF (INCX.EQ.0) THEN
|
||||
INFO = 5
|
||||
ELSE IF (INCY.EQ.0) THEN
|
||||
INFO = 7
|
||||
ELSE IF (LDA.LT.MAX(1,N)) THEN
|
||||
INFO = 9
|
||||
END IF
|
||||
IF (INFO.NE.0) THEN
|
||||
CALL XERBLA('ZHER2 ',INFO)
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible.
|
||||
*
|
||||
IF ((N.EQ.0) .OR. (ALPHA.EQ.ZERO)) RETURN
|
||||
*
|
||||
* Set up the start points in X and Y if the increments are not both
|
||||
* unity.
|
||||
*
|
||||
IF ((INCX.NE.1) .OR. (INCY.NE.1)) THEN
|
||||
IF (INCX.GT.0) THEN
|
||||
KX = 1
|
||||
ELSE
|
||||
KX = 1 - (N-1)*INCX
|
||||
END IF
|
||||
IF (INCY.GT.0) THEN
|
||||
KY = 1
|
||||
ELSE
|
||||
KY = 1 - (N-1)*INCY
|
||||
END IF
|
||||
JX = KX
|
||||
JY = KY
|
||||
END IF
|
||||
*
|
||||
* Start the operations. In this version the elements of A are
|
||||
* accessed sequentially with one pass through the triangular part
|
||||
* of A.
|
||||
*
|
||||
IF (LSAME(UPLO,'U')) THEN
|
||||
*
|
||||
* Form A when A is stored in the upper triangle.
|
||||
*
|
||||
IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
|
||||
DO 20 J = 1,N
|
||||
IF ((X(J).NE.ZERO) .OR. (Y(J).NE.ZERO)) THEN
|
||||
TEMP1 = ALPHA*DCONJG(Y(J))
|
||||
TEMP2 = DCONJG(ALPHA*X(J))
|
||||
DO 10 I = 1,J - 1
|
||||
A(I,J) = A(I,J) + X(I)*TEMP1 + Y(I)*TEMP2
|
||||
10 CONTINUE
|
||||
A(J,J) = DBLE(A(J,J)) +
|
||||
+ DBLE(X(J)*TEMP1+Y(J)*TEMP2)
|
||||
ELSE
|
||||
A(J,J) = DBLE(A(J,J))
|
||||
END IF
|
||||
20 CONTINUE
|
||||
ELSE
|
||||
DO 40 J = 1,N
|
||||
IF ((X(JX).NE.ZERO) .OR. (Y(JY).NE.ZERO)) THEN
|
||||
TEMP1 = ALPHA*DCONJG(Y(JY))
|
||||
TEMP2 = DCONJG(ALPHA*X(JX))
|
||||
IX = KX
|
||||
IY = KY
|
||||
DO 30 I = 1,J - 1
|
||||
A(I,J) = A(I,J) + X(IX)*TEMP1 + Y(IY)*TEMP2
|
||||
IX = IX + INCX
|
||||
IY = IY + INCY
|
||||
30 CONTINUE
|
||||
A(J,J) = DBLE(A(J,J)) +
|
||||
+ DBLE(X(JX)*TEMP1+Y(JY)*TEMP2)
|
||||
ELSE
|
||||
A(J,J) = DBLE(A(J,J))
|
||||
END IF
|
||||
JX = JX + INCX
|
||||
JY = JY + INCY
|
||||
40 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
*
|
||||
* Form A when A is stored in the lower triangle.
|
||||
*
|
||||
IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
|
||||
DO 60 J = 1,N
|
||||
IF ((X(J).NE.ZERO) .OR. (Y(J).NE.ZERO)) THEN
|
||||
TEMP1 = ALPHA*DCONJG(Y(J))
|
||||
TEMP2 = DCONJG(ALPHA*X(J))
|
||||
A(J,J) = DBLE(A(J,J)) +
|
||||
+ DBLE(X(J)*TEMP1+Y(J)*TEMP2)
|
||||
DO 50 I = J + 1,N
|
||||
A(I,J) = A(I,J) + X(I)*TEMP1 + Y(I)*TEMP2
|
||||
50 CONTINUE
|
||||
ELSE
|
||||
A(J,J) = DBLE(A(J,J))
|
||||
END IF
|
||||
60 CONTINUE
|
||||
ELSE
|
||||
DO 80 J = 1,N
|
||||
IF ((X(JX).NE.ZERO) .OR. (Y(JY).NE.ZERO)) THEN
|
||||
TEMP1 = ALPHA*DCONJG(Y(JY))
|
||||
TEMP2 = DCONJG(ALPHA*X(JX))
|
||||
A(J,J) = DBLE(A(J,J)) +
|
||||
+ DBLE(X(JX)*TEMP1+Y(JY)*TEMP2)
|
||||
IX = JX
|
||||
IY = JY
|
||||
DO 70 I = J + 1,N
|
||||
IX = IX + INCX
|
||||
IY = IY + INCY
|
||||
A(I,J) = A(I,J) + X(IX)*TEMP1 + Y(IY)*TEMP2
|
||||
70 CONTINUE
|
||||
ELSE
|
||||
A(J,J) = DBLE(A(J,J))
|
||||
END IF
|
||||
JX = JX + INCX
|
||||
JY = JY + INCY
|
||||
80 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of ZHER2 .
|
||||
*
|
||||
END
|
||||
443
lib/linalg/zher2k.f
Normal file
443
lib/linalg/zher2k.f
Normal file
@ -0,0 +1,443 @@
|
||||
*> \brief \b ZHER2K
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE ZHER2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* COMPLEX*16 ALPHA
|
||||
* DOUBLE PRECISION BETA
|
||||
* INTEGER K,LDA,LDB,LDC,N
|
||||
* CHARACTER TRANS,UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* COMPLEX*16 A(LDA,*),B(LDB,*),C(LDC,*)
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> ZHER2K performs one of the hermitian rank 2k operations
|
||||
*>
|
||||
*> C := alpha*A*B**H + conjg( alpha )*B*A**H + beta*C,
|
||||
*>
|
||||
*> or
|
||||
*>
|
||||
*> C := alpha*A**H*B + conjg( alpha )*B**H*A + beta*C,
|
||||
*>
|
||||
*> where alpha and beta are scalars with beta real, C is an n by n
|
||||
*> hermitian matrix and A and B are n by k matrices in the first case
|
||||
*> and k by n matrices in the second case.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] UPLO
|
||||
*> \verbatim
|
||||
*> UPLO is CHARACTER*1
|
||||
*> On entry, UPLO specifies whether the upper or lower
|
||||
*> triangular part of the array C is to be referenced as
|
||||
*> follows:
|
||||
*>
|
||||
*> UPLO = 'U' or 'u' Only the upper triangular part of C
|
||||
*> is to be referenced.
|
||||
*>
|
||||
*> UPLO = 'L' or 'l' Only the lower triangular part of C
|
||||
*> is to be referenced.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] TRANS
|
||||
*> \verbatim
|
||||
*> TRANS is CHARACTER*1
|
||||
*> On entry, TRANS specifies the operation to be performed as
|
||||
*> follows:
|
||||
*>
|
||||
*> TRANS = 'N' or 'n' C := alpha*A*B**H +
|
||||
*> conjg( alpha )*B*A**H +
|
||||
*> beta*C.
|
||||
*>
|
||||
*> TRANS = 'C' or 'c' C := alpha*A**H*B +
|
||||
*> conjg( alpha )*B**H*A +
|
||||
*> beta*C.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> On entry, N specifies the order of the matrix C. N must be
|
||||
*> at least zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] K
|
||||
*> \verbatim
|
||||
*> K is INTEGER
|
||||
*> On entry with TRANS = 'N' or 'n', K specifies the number
|
||||
*> of columns of the matrices A and B, and on entry with
|
||||
*> TRANS = 'C' or 'c', K specifies the number of rows of the
|
||||
*> matrices A and B. K must be at least zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] ALPHA
|
||||
*> \verbatim
|
||||
*> ALPHA is COMPLEX*16 .
|
||||
*> On entry, ALPHA specifies the scalar alpha.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] A
|
||||
*> \verbatim
|
||||
*> A is COMPLEX*16 array of DIMENSION ( LDA, ka ), where ka is
|
||||
*> k when TRANS = 'N' or 'n', and is n otherwise.
|
||||
*> Before entry with TRANS = 'N' or 'n', the leading n by k
|
||||
*> part of the array A must contain the matrix A, otherwise
|
||||
*> the leading k by n part of the array A must contain the
|
||||
*> matrix A.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> On entry, LDA specifies the first dimension of A as declared
|
||||
*> in the calling (sub) program. When TRANS = 'N' or 'n'
|
||||
*> then LDA must be at least max( 1, n ), otherwise LDA must
|
||||
*> be at least max( 1, k ).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] B
|
||||
*> \verbatim
|
||||
*> B is COMPLEX*16 array of DIMENSION ( LDB, kb ), where kb is
|
||||
*> k when TRANS = 'N' or 'n', and is n otherwise.
|
||||
*> Before entry with TRANS = 'N' or 'n', the leading n by k
|
||||
*> part of the array B must contain the matrix B, otherwise
|
||||
*> the leading k by n part of the array B must contain the
|
||||
*> matrix B.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDB
|
||||
*> \verbatim
|
||||
*> LDB is INTEGER
|
||||
*> On entry, LDB specifies the first dimension of B as declared
|
||||
*> in the calling (sub) program. When TRANS = 'N' or 'n'
|
||||
*> then LDB must be at least max( 1, n ), otherwise LDB must
|
||||
*> be at least max( 1, k ).
|
||||
*> Unchanged on exit.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] BETA
|
||||
*> \verbatim
|
||||
*> BETA is DOUBLE PRECISION .
|
||||
*> On entry, BETA specifies the scalar beta.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] C
|
||||
*> \verbatim
|
||||
*> C is COMPLEX*16 array of DIMENSION ( LDC, n ).
|
||||
*> Before entry with UPLO = 'U' or 'u', the leading n by n
|
||||
*> upper triangular part of the array C must contain the upper
|
||||
*> triangular part of the hermitian matrix and the strictly
|
||||
*> lower triangular part of C is not referenced. On exit, the
|
||||
*> upper triangular part of the array C is overwritten by the
|
||||
*> upper triangular part of the updated matrix.
|
||||
*> Before entry with UPLO = 'L' or 'l', the leading n by n
|
||||
*> lower triangular part of the array C must contain the lower
|
||||
*> triangular part of the hermitian matrix and the strictly
|
||||
*> upper triangular part of C is not referenced. On exit, the
|
||||
*> lower triangular part of the array C is overwritten by the
|
||||
*> lower triangular part of the updated matrix.
|
||||
*> Note that the imaginary parts of the diagonal elements need
|
||||
*> not be set, they are assumed to be zero, and on exit they
|
||||
*> are set to zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDC
|
||||
*> \verbatim
|
||||
*> LDC is INTEGER
|
||||
*> On entry, LDC specifies the first dimension of C as declared
|
||||
*> in the calling (sub) program. LDC must be at least
|
||||
*> max( 1, n ).
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup complex16_blas_level3
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> Level 3 Blas routine.
|
||||
*>
|
||||
*> -- Written on 8-February-1989.
|
||||
*> Jack Dongarra, Argonne National Laboratory.
|
||||
*> Iain Duff, AERE Harwell.
|
||||
*> Jeremy Du Croz, Numerical Algorithms Group Ltd.
|
||||
*> Sven Hammarling, Numerical Algorithms Group Ltd.
|
||||
*>
|
||||
*> -- Modified 8-Nov-93 to set C(J,J) to DBLE( C(J,J) ) when BETA = 1.
|
||||
*> Ed Anderson, Cray Research Inc.
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
SUBROUTINE ZHER2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
|
||||
*
|
||||
* -- Reference BLAS level3 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
COMPLEX*16 ALPHA
|
||||
DOUBLE PRECISION BETA
|
||||
INTEGER K,LDA,LDB,LDC,N
|
||||
CHARACTER TRANS,UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
COMPLEX*16 A(LDA,*),B(LDB,*),C(LDC,*)
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
EXTERNAL LSAME
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC DBLE,DCONJG,MAX
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
COMPLEX*16 TEMP1,TEMP2
|
||||
INTEGER I,INFO,J,L,NROWA
|
||||
LOGICAL UPPER
|
||||
* ..
|
||||
* .. Parameters ..
|
||||
DOUBLE PRECISION ONE
|
||||
PARAMETER (ONE=1.0D+0)
|
||||
COMPLEX*16 ZERO
|
||||
PARAMETER (ZERO= (0.0D+0,0.0D+0))
|
||||
* ..
|
||||
*
|
||||
* Test the input parameters.
|
||||
*
|
||||
IF (LSAME(TRANS,'N')) THEN
|
||||
NROWA = N
|
||||
ELSE
|
||||
NROWA = K
|
||||
END IF
|
||||
UPPER = LSAME(UPLO,'U')
|
||||
*
|
||||
INFO = 0
|
||||
IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN
|
||||
INFO = 1
|
||||
ELSE IF ((.NOT.LSAME(TRANS,'N')) .AND.
|
||||
+ (.NOT.LSAME(TRANS,'C'))) THEN
|
||||
INFO = 2
|
||||
ELSE IF (N.LT.0) THEN
|
||||
INFO = 3
|
||||
ELSE IF (K.LT.0) THEN
|
||||
INFO = 4
|
||||
ELSE IF (LDA.LT.MAX(1,NROWA)) THEN
|
||||
INFO = 7
|
||||
ELSE IF (LDB.LT.MAX(1,NROWA)) THEN
|
||||
INFO = 9
|
||||
ELSE IF (LDC.LT.MAX(1,N)) THEN
|
||||
INFO = 12
|
||||
END IF
|
||||
IF (INFO.NE.0) THEN
|
||||
CALL XERBLA('ZHER2K',INFO)
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible.
|
||||
*
|
||||
IF ((N.EQ.0) .OR. (((ALPHA.EQ.ZERO).OR.
|
||||
+ (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN
|
||||
*
|
||||
* And when alpha.eq.zero.
|
||||
*
|
||||
IF (ALPHA.EQ.ZERO) THEN
|
||||
IF (UPPER) THEN
|
||||
IF (BETA.EQ.DBLE(ZERO)) THEN
|
||||
DO 20 J = 1,N
|
||||
DO 10 I = 1,J
|
||||
C(I,J) = ZERO
|
||||
10 CONTINUE
|
||||
20 CONTINUE
|
||||
ELSE
|
||||
DO 40 J = 1,N
|
||||
DO 30 I = 1,J - 1
|
||||
C(I,J) = BETA*C(I,J)
|
||||
30 CONTINUE
|
||||
C(J,J) = BETA*DBLE(C(J,J))
|
||||
40 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
IF (BETA.EQ.DBLE(ZERO)) THEN
|
||||
DO 60 J = 1,N
|
||||
DO 50 I = J,N
|
||||
C(I,J) = ZERO
|
||||
50 CONTINUE
|
||||
60 CONTINUE
|
||||
ELSE
|
||||
DO 80 J = 1,N
|
||||
C(J,J) = BETA*DBLE(C(J,J))
|
||||
DO 70 I = J + 1,N
|
||||
C(I,J) = BETA*C(I,J)
|
||||
70 CONTINUE
|
||||
80 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Start the operations.
|
||||
*
|
||||
IF (LSAME(TRANS,'N')) THEN
|
||||
*
|
||||
* Form C := alpha*A*B**H + conjg( alpha )*B*A**H +
|
||||
* C.
|
||||
*
|
||||
IF (UPPER) THEN
|
||||
DO 130 J = 1,N
|
||||
IF (BETA.EQ.DBLE(ZERO)) THEN
|
||||
DO 90 I = 1,J
|
||||
C(I,J) = ZERO
|
||||
90 CONTINUE
|
||||
ELSE IF (BETA.NE.ONE) THEN
|
||||
DO 100 I = 1,J - 1
|
||||
C(I,J) = BETA*C(I,J)
|
||||
100 CONTINUE
|
||||
C(J,J) = BETA*DBLE(C(J,J))
|
||||
ELSE
|
||||
C(J,J) = DBLE(C(J,J))
|
||||
END IF
|
||||
DO 120 L = 1,K
|
||||
IF ((A(J,L).NE.ZERO) .OR. (B(J,L).NE.ZERO)) THEN
|
||||
TEMP1 = ALPHA*DCONJG(B(J,L))
|
||||
TEMP2 = DCONJG(ALPHA*A(J,L))
|
||||
DO 110 I = 1,J - 1
|
||||
C(I,J) = C(I,J) + A(I,L)*TEMP1 +
|
||||
+ B(I,L)*TEMP2
|
||||
110 CONTINUE
|
||||
C(J,J) = DBLE(C(J,J)) +
|
||||
+ DBLE(A(J,L)*TEMP1+B(J,L)*TEMP2)
|
||||
END IF
|
||||
120 CONTINUE
|
||||
130 CONTINUE
|
||||
ELSE
|
||||
DO 180 J = 1,N
|
||||
IF (BETA.EQ.DBLE(ZERO)) THEN
|
||||
DO 140 I = J,N
|
||||
C(I,J) = ZERO
|
||||
140 CONTINUE
|
||||
ELSE IF (BETA.NE.ONE) THEN
|
||||
DO 150 I = J + 1,N
|
||||
C(I,J) = BETA*C(I,J)
|
||||
150 CONTINUE
|
||||
C(J,J) = BETA*DBLE(C(J,J))
|
||||
ELSE
|
||||
C(J,J) = DBLE(C(J,J))
|
||||
END IF
|
||||
DO 170 L = 1,K
|
||||
IF ((A(J,L).NE.ZERO) .OR. (B(J,L).NE.ZERO)) THEN
|
||||
TEMP1 = ALPHA*DCONJG(B(J,L))
|
||||
TEMP2 = DCONJG(ALPHA*A(J,L))
|
||||
DO 160 I = J + 1,N
|
||||
C(I,J) = C(I,J) + A(I,L)*TEMP1 +
|
||||
+ B(I,L)*TEMP2
|
||||
160 CONTINUE
|
||||
C(J,J) = DBLE(C(J,J)) +
|
||||
+ DBLE(A(J,L)*TEMP1+B(J,L)*TEMP2)
|
||||
END IF
|
||||
170 CONTINUE
|
||||
180 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
*
|
||||
* Form C := alpha*A**H*B + conjg( alpha )*B**H*A +
|
||||
* C.
|
||||
*
|
||||
IF (UPPER) THEN
|
||||
DO 210 J = 1,N
|
||||
DO 200 I = 1,J
|
||||
TEMP1 = ZERO
|
||||
TEMP2 = ZERO
|
||||
DO 190 L = 1,K
|
||||
TEMP1 = TEMP1 + DCONJG(A(L,I))*B(L,J)
|
||||
TEMP2 = TEMP2 + DCONJG(B(L,I))*A(L,J)
|
||||
190 CONTINUE
|
||||
IF (I.EQ.J) THEN
|
||||
IF (BETA.EQ.DBLE(ZERO)) THEN
|
||||
C(J,J) = DBLE(ALPHA*TEMP1+
|
||||
+ DCONJG(ALPHA)*TEMP2)
|
||||
ELSE
|
||||
C(J,J) = BETA*DBLE(C(J,J)) +
|
||||
+ DBLE(ALPHA*TEMP1+
|
||||
+ DCONJG(ALPHA)*TEMP2)
|
||||
END IF
|
||||
ELSE
|
||||
IF (BETA.EQ.DBLE(ZERO)) THEN
|
||||
C(I,J) = ALPHA*TEMP1 + DCONJG(ALPHA)*TEMP2
|
||||
ELSE
|
||||
C(I,J) = BETA*C(I,J) + ALPHA*TEMP1 +
|
||||
+ DCONJG(ALPHA)*TEMP2
|
||||
END IF
|
||||
END IF
|
||||
200 CONTINUE
|
||||
210 CONTINUE
|
||||
ELSE
|
||||
DO 240 J = 1,N
|
||||
DO 230 I = J,N
|
||||
TEMP1 = ZERO
|
||||
TEMP2 = ZERO
|
||||
DO 220 L = 1,K
|
||||
TEMP1 = TEMP1 + DCONJG(A(L,I))*B(L,J)
|
||||
TEMP2 = TEMP2 + DCONJG(B(L,I))*A(L,J)
|
||||
220 CONTINUE
|
||||
IF (I.EQ.J) THEN
|
||||
IF (BETA.EQ.DBLE(ZERO)) THEN
|
||||
C(J,J) = DBLE(ALPHA*TEMP1+
|
||||
+ DCONJG(ALPHA)*TEMP2)
|
||||
ELSE
|
||||
C(J,J) = BETA*DBLE(C(J,J)) +
|
||||
+ DBLE(ALPHA*TEMP1+
|
||||
+ DCONJG(ALPHA)*TEMP2)
|
||||
END IF
|
||||
ELSE
|
||||
IF (BETA.EQ.DBLE(ZERO)) THEN
|
||||
C(I,J) = ALPHA*TEMP1 + DCONJG(ALPHA)*TEMP2
|
||||
ELSE
|
||||
C(I,J) = BETA*C(I,J) + ALPHA*TEMP1 +
|
||||
+ DCONJG(ALPHA)*TEMP2
|
||||
END IF
|
||||
END IF
|
||||
230 CONTINUE
|
||||
240 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of ZHER2K.
|
||||
*
|
||||
END
|
||||
334
lib/linalg/zhetd2.f
Normal file
334
lib/linalg/zhetd2.f
Normal file
@ -0,0 +1,334 @@
|
||||
*> \brief \b ZHETD2 reduces a Hermitian matrix to real symmetric tridiagonal form by an unitary similarity transformation (unblocked algorithm).
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
*> \htmlonly
|
||||
*> Download ZHETD2 + dependencies
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zhetd2.f">
|
||||
*> [TGZ]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zhetd2.f">
|
||||
*> [ZIP]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zhetd2.f">
|
||||
*> [TXT]</a>
|
||||
*> \endhtmlonly
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE ZHETD2( UPLO, N, A, LDA, D, E, TAU, INFO )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* CHARACTER UPLO
|
||||
* INTEGER INFO, LDA, N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* DOUBLE PRECISION D( * ), E( * )
|
||||
* COMPLEX*16 A( LDA, * ), TAU( * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> ZHETD2 reduces a complex Hermitian matrix A to real symmetric
|
||||
*> tridiagonal form T by a unitary similarity transformation:
|
||||
*> Q**H * A * Q = T.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] UPLO
|
||||
*> \verbatim
|
||||
*> UPLO is CHARACTER*1
|
||||
*> Specifies whether the upper or lower triangular part of the
|
||||
*> Hermitian matrix A is stored:
|
||||
*> = 'U': Upper triangular
|
||||
*> = 'L': Lower triangular
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> The order of the matrix A. N >= 0.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] A
|
||||
*> \verbatim
|
||||
*> A is COMPLEX*16 array, dimension (LDA,N)
|
||||
*> On entry, the Hermitian matrix A. If UPLO = 'U', the leading
|
||||
*> n-by-n upper triangular part of A contains the upper
|
||||
*> triangular part of the matrix A, and the strictly lower
|
||||
*> triangular part of A is not referenced. If UPLO = 'L', the
|
||||
*> leading n-by-n lower triangular part of A contains the lower
|
||||
*> triangular part of the matrix A, and the strictly upper
|
||||
*> triangular part of A is not referenced.
|
||||
*> On exit, if UPLO = 'U', the diagonal and first superdiagonal
|
||||
*> of A are overwritten by the corresponding elements of the
|
||||
*> tridiagonal matrix T, and the elements above the first
|
||||
*> superdiagonal, with the array TAU, represent the unitary
|
||||
*> matrix Q as a product of elementary reflectors; if UPLO
|
||||
*> = 'L', the diagonal and first subdiagonal of A are over-
|
||||
*> written by the corresponding elements of the tridiagonal
|
||||
*> matrix T, and the elements below the first subdiagonal, with
|
||||
*> the array TAU, represent the unitary matrix Q as a product
|
||||
*> of elementary reflectors. See Further Details.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> The leading dimension of the array A. LDA >= max(1,N).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] D
|
||||
*> \verbatim
|
||||
*> D is DOUBLE PRECISION array, dimension (N)
|
||||
*> The diagonal elements of the tridiagonal matrix T:
|
||||
*> D(i) = A(i,i).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] E
|
||||
*> \verbatim
|
||||
*> E is DOUBLE PRECISION array, dimension (N-1)
|
||||
*> The off-diagonal elements of the tridiagonal matrix T:
|
||||
*> E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] TAU
|
||||
*> \verbatim
|
||||
*> TAU is COMPLEX*16 array, dimension (N-1)
|
||||
*> The scalar factors of the elementary reflectors (see Further
|
||||
*> Details).
|
||||
*> \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 September 2012
|
||||
*
|
||||
*> \ingroup complex16HEcomputational
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> If UPLO = 'U', the matrix Q is represented as a product of elementary
|
||||
*> reflectors
|
||||
*>
|
||||
*> Q = H(n-1) . . . H(2) H(1).
|
||||
*>
|
||||
*> Each H(i) has the form
|
||||
*>
|
||||
*> H(i) = I - tau * v * v**H
|
||||
*>
|
||||
*> where tau is a complex scalar, and v is a complex vector with
|
||||
*> v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in
|
||||
*> A(1:i-1,i+1), and tau in TAU(i).
|
||||
*>
|
||||
*> If UPLO = 'L', the matrix Q is represented as a product of elementary
|
||||
*> reflectors
|
||||
*>
|
||||
*> Q = H(1) H(2) . . . H(n-1).
|
||||
*>
|
||||
*> Each H(i) has the form
|
||||
*>
|
||||
*> H(i) = I - tau * v * v**H
|
||||
*>
|
||||
*> where tau is a complex scalar, and v is a complex vector with
|
||||
*> v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i),
|
||||
*> and tau in TAU(i).
|
||||
*>
|
||||
*> The contents of A on exit are illustrated by the following examples
|
||||
*> with n = 5:
|
||||
*>
|
||||
*> if UPLO = 'U': if UPLO = 'L':
|
||||
*>
|
||||
*> ( d e v2 v3 v4 ) ( d )
|
||||
*> ( d e v3 v4 ) ( e d )
|
||||
*> ( d e v4 ) ( v1 e d )
|
||||
*> ( d e ) ( v1 v2 e d )
|
||||
*> ( d ) ( v1 v2 v3 e d )
|
||||
*>
|
||||
*> where d and e denote diagonal and off-diagonal elements of T, and vi
|
||||
*> denotes an element of the vector defining H(i).
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
SUBROUTINE ZHETD2( UPLO, N, A, LDA, D, E, TAU, INFO )
|
||||
*
|
||||
* -- LAPACK computational routine (version 3.4.2) --
|
||||
* -- 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 ..
|
||||
CHARACTER UPLO
|
||||
INTEGER INFO, LDA, N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION D( * ), E( * )
|
||||
COMPLEX*16 A( LDA, * ), TAU( * )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
COMPLEX*16 ONE, ZERO, HALF
|
||||
PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ),
|
||||
$ ZERO = ( 0.0D+0, 0.0D+0 ),
|
||||
$ HALF = ( 0.5D+0, 0.0D+0 ) )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
LOGICAL UPPER
|
||||
INTEGER I
|
||||
COMPLEX*16 ALPHA, TAUI
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA, ZAXPY, ZHEMV, ZHER2, ZLARFG
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
COMPLEX*16 ZDOTC
|
||||
EXTERNAL LSAME, ZDOTC
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC DBLE, MAX, MIN
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* Test the input parameters
|
||||
*
|
||||
INFO = 0
|
||||
UPPER = LSAME( UPLO, 'U')
|
||||
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
|
||||
INFO = -1
|
||||
ELSE IF( N.LT.0 ) THEN
|
||||
INFO = -2
|
||||
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
|
||||
INFO = -4
|
||||
END IF
|
||||
IF( INFO.NE.0 ) THEN
|
||||
CALL XERBLA( 'ZHETD2', -INFO )
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible
|
||||
*
|
||||
IF( N.LE.0 )
|
||||
$ RETURN
|
||||
*
|
||||
IF( UPPER ) THEN
|
||||
*
|
||||
* Reduce the upper triangle of A
|
||||
*
|
||||
A( N, N ) = DBLE( A( N, N ) )
|
||||
DO 10 I = N - 1, 1, -1
|
||||
*
|
||||
* Generate elementary reflector H(i) = I - tau * v * v**H
|
||||
* to annihilate A(1:i-1,i+1)
|
||||
*
|
||||
ALPHA = A( I, I+1 )
|
||||
CALL ZLARFG( I, ALPHA, A( 1, I+1 ), 1, TAUI )
|
||||
E( I ) = ALPHA
|
||||
*
|
||||
IF( TAUI.NE.ZERO ) THEN
|
||||
*
|
||||
* Apply H(i) from both sides to A(1:i,1:i)
|
||||
*
|
||||
A( I, I+1 ) = ONE
|
||||
*
|
||||
* Compute x := tau * A * v storing x in TAU(1:i)
|
||||
*
|
||||
CALL ZHEMV( UPLO, I, TAUI, A, LDA, A( 1, I+1 ), 1, ZERO,
|
||||
$ TAU, 1 )
|
||||
*
|
||||
* Compute w := x - 1/2 * tau * (x**H * v) * v
|
||||
*
|
||||
ALPHA = -HALF*TAUI*ZDOTC( I, TAU, 1, A( 1, I+1 ), 1 )
|
||||
CALL ZAXPY( I, ALPHA, A( 1, I+1 ), 1, TAU, 1 )
|
||||
*
|
||||
* Apply the transformation as a rank-2 update:
|
||||
* A := A - v * w**H - w * v**H
|
||||
*
|
||||
CALL ZHER2( UPLO, I, -ONE, A( 1, I+1 ), 1, TAU, 1, A,
|
||||
$ LDA )
|
||||
*
|
||||
ELSE
|
||||
A( I, I ) = DBLE( A( I, I ) )
|
||||
END IF
|
||||
A( I, I+1 ) = E( I )
|
||||
D( I+1 ) = A( I+1, I+1 )
|
||||
TAU( I ) = TAUI
|
||||
10 CONTINUE
|
||||
D( 1 ) = A( 1, 1 )
|
||||
ELSE
|
||||
*
|
||||
* Reduce the lower triangle of A
|
||||
*
|
||||
A( 1, 1 ) = DBLE( A( 1, 1 ) )
|
||||
DO 20 I = 1, N - 1
|
||||
*
|
||||
* Generate elementary reflector H(i) = I - tau * v * v**H
|
||||
* to annihilate A(i+2:n,i)
|
||||
*
|
||||
ALPHA = A( I+1, I )
|
||||
CALL ZLARFG( N-I, ALPHA, A( MIN( I+2, N ), I ), 1, TAUI )
|
||||
E( I ) = ALPHA
|
||||
*
|
||||
IF( TAUI.NE.ZERO ) THEN
|
||||
*
|
||||
* Apply H(i) from both sides to A(i+1:n,i+1:n)
|
||||
*
|
||||
A( I+1, I ) = ONE
|
||||
*
|
||||
* Compute x := tau * A * v storing y in TAU(i:n-1)
|
||||
*
|
||||
CALL ZHEMV( UPLO, N-I, TAUI, A( I+1, I+1 ), LDA,
|
||||
$ A( I+1, I ), 1, ZERO, TAU( I ), 1 )
|
||||
*
|
||||
* Compute w := x - 1/2 * tau * (x**H * v) * v
|
||||
*
|
||||
ALPHA = -HALF*TAUI*ZDOTC( N-I, TAU( I ), 1, A( I+1, I ),
|
||||
$ 1 )
|
||||
CALL ZAXPY( N-I, ALPHA, A( I+1, I ), 1, TAU( I ), 1 )
|
||||
*
|
||||
* Apply the transformation as a rank-2 update:
|
||||
* A := A - v * w**H - w * v**H
|
||||
*
|
||||
CALL ZHER2( UPLO, N-I, -ONE, A( I+1, I ), 1, TAU( I ), 1,
|
||||
$ A( I+1, I+1 ), LDA )
|
||||
*
|
||||
ELSE
|
||||
A( I+1, I+1 ) = DBLE( A( I+1, I+1 ) )
|
||||
END IF
|
||||
A( I+1, I ) = E( I )
|
||||
D( I ) = A( I, I )
|
||||
TAU( I ) = TAUI
|
||||
20 CONTINUE
|
||||
D( N ) = A( N, N )
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of ZHETD2
|
||||
*
|
||||
END
|
||||
378
lib/linalg/zhetrd.f
Normal file
378
lib/linalg/zhetrd.f
Normal file
@ -0,0 +1,378 @@
|
||||
*> \brief \b ZHETRD
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
*> \htmlonly
|
||||
*> Download ZHETRD + dependencies
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zhetrd.f">
|
||||
*> [TGZ]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zhetrd.f">
|
||||
*> [ZIP]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zhetrd.f">
|
||||
*> [TXT]</a>
|
||||
*> \endhtmlonly
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE ZHETRD( UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, INFO )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* CHARACTER UPLO
|
||||
* INTEGER INFO, LDA, LWORK, N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* DOUBLE PRECISION D( * ), E( * )
|
||||
* COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> ZHETRD reduces a complex Hermitian matrix A to real symmetric
|
||||
*> tridiagonal form T by a unitary similarity transformation:
|
||||
*> Q**H * A * Q = T.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] UPLO
|
||||
*> \verbatim
|
||||
*> UPLO is CHARACTER*1
|
||||
*> = 'U': Upper triangle of A is stored;
|
||||
*> = 'L': Lower triangle of A is stored.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> The order of the matrix A. N >= 0.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] A
|
||||
*> \verbatim
|
||||
*> A is COMPLEX*16 array, dimension (LDA,N)
|
||||
*> On entry, the Hermitian matrix A. If UPLO = 'U', the leading
|
||||
*> N-by-N upper triangular part of A contains the upper
|
||||
*> triangular part of the matrix A, and the strictly lower
|
||||
*> triangular part of A is not referenced. If UPLO = 'L', the
|
||||
*> leading N-by-N lower triangular part of A contains the lower
|
||||
*> triangular part of the matrix A, and the strictly upper
|
||||
*> triangular part of A is not referenced.
|
||||
*> On exit, if UPLO = 'U', the diagonal and first superdiagonal
|
||||
*> of A are overwritten by the corresponding elements of the
|
||||
*> tridiagonal matrix T, and the elements above the first
|
||||
*> superdiagonal, with the array TAU, represent the unitary
|
||||
*> matrix Q as a product of elementary reflectors; if UPLO
|
||||
*> = 'L', the diagonal and first subdiagonal of A are over-
|
||||
*> written by the corresponding elements of the tridiagonal
|
||||
*> matrix T, and the elements below the first subdiagonal, with
|
||||
*> the array TAU, represent the unitary matrix Q as a product
|
||||
*> of elementary reflectors. See Further Details.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> The leading dimension of the array A. LDA >= max(1,N).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] D
|
||||
*> \verbatim
|
||||
*> D is DOUBLE PRECISION array, dimension (N)
|
||||
*> The diagonal elements of the tridiagonal matrix T:
|
||||
*> D(i) = A(i,i).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] E
|
||||
*> \verbatim
|
||||
*> E is DOUBLE PRECISION array, dimension (N-1)
|
||||
*> The off-diagonal elements of the tridiagonal matrix T:
|
||||
*> E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] TAU
|
||||
*> \verbatim
|
||||
*> TAU is COMPLEX*16 array, dimension (N-1)
|
||||
*> The scalar factors of the elementary reflectors (see Further
|
||||
*> Details).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] WORK
|
||||
*> \verbatim
|
||||
*> WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
|
||||
*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LWORK
|
||||
*> \verbatim
|
||||
*> LWORK is INTEGER
|
||||
*> The dimension of the array WORK. LWORK >= 1.
|
||||
*> For optimum performance LWORK >= N*NB, where NB is the
|
||||
*> optimal blocksize.
|
||||
*>
|
||||
*> If LWORK = -1, then a workspace query is assumed; the routine
|
||||
*> only calculates the optimal size of the WORK array, returns
|
||||
*> this value as the first entry of the WORK array, and no error
|
||||
*> message related to LWORK is issued by XERBLA.
|
||||
*> \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 November 2011
|
||||
*
|
||||
*> \ingroup complex16HEcomputational
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> If UPLO = 'U', the matrix Q is represented as a product of elementary
|
||||
*> reflectors
|
||||
*>
|
||||
*> Q = H(n-1) . . . H(2) H(1).
|
||||
*>
|
||||
*> Each H(i) has the form
|
||||
*>
|
||||
*> H(i) = I - tau * v * v**H
|
||||
*>
|
||||
*> where tau is a complex scalar, and v is a complex vector with
|
||||
*> v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in
|
||||
*> A(1:i-1,i+1), and tau in TAU(i).
|
||||
*>
|
||||
*> If UPLO = 'L', the matrix Q is represented as a product of elementary
|
||||
*> reflectors
|
||||
*>
|
||||
*> Q = H(1) H(2) . . . H(n-1).
|
||||
*>
|
||||
*> Each H(i) has the form
|
||||
*>
|
||||
*> H(i) = I - tau * v * v**H
|
||||
*>
|
||||
*> where tau is a complex scalar, and v is a complex vector with
|
||||
*> v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i),
|
||||
*> and tau in TAU(i).
|
||||
*>
|
||||
*> The contents of A on exit are illustrated by the following examples
|
||||
*> with n = 5:
|
||||
*>
|
||||
*> if UPLO = 'U': if UPLO = 'L':
|
||||
*>
|
||||
*> ( d e v2 v3 v4 ) ( d )
|
||||
*> ( d e v3 v4 ) ( e d )
|
||||
*> ( d e v4 ) ( v1 e d )
|
||||
*> ( d e ) ( v1 v2 e d )
|
||||
*> ( d ) ( v1 v2 v3 e d )
|
||||
*>
|
||||
*> where d and e denote diagonal and off-diagonal elements of T, and vi
|
||||
*> denotes an element of the vector defining H(i).
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
SUBROUTINE ZHETRD( UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, INFO )
|
||||
*
|
||||
* -- LAPACK computational routine (version 3.4.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
CHARACTER UPLO
|
||||
INTEGER INFO, LDA, LWORK, N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION D( * ), E( * )
|
||||
COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
DOUBLE PRECISION ONE
|
||||
PARAMETER ( ONE = 1.0D+0 )
|
||||
COMPLEX*16 CONE
|
||||
PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ) )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
LOGICAL LQUERY, UPPER
|
||||
INTEGER I, IINFO, IWS, J, KK, LDWORK, LWKOPT, NB,
|
||||
$ NBMIN, NX
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA, ZHER2K, ZHETD2, ZLATRD
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC MAX
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
INTEGER ILAENV
|
||||
EXTERNAL LSAME, ILAENV
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* Test the input parameters
|
||||
*
|
||||
INFO = 0
|
||||
UPPER = LSAME( UPLO, 'U' )
|
||||
LQUERY = ( LWORK.EQ.-1 )
|
||||
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
|
||||
INFO = -1
|
||||
ELSE IF( N.LT.0 ) THEN
|
||||
INFO = -2
|
||||
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
|
||||
INFO = -4
|
||||
ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN
|
||||
INFO = -9
|
||||
END IF
|
||||
*
|
||||
IF( INFO.EQ.0 ) THEN
|
||||
*
|
||||
* Determine the block size.
|
||||
*
|
||||
NB = ILAENV( 1, 'ZHETRD', UPLO, N, -1, -1, -1 )
|
||||
LWKOPT = N*NB
|
||||
WORK( 1 ) = LWKOPT
|
||||
END IF
|
||||
*
|
||||
IF( INFO.NE.0 ) THEN
|
||||
CALL XERBLA( 'ZHETRD', -INFO )
|
||||
RETURN
|
||||
ELSE IF( LQUERY ) THEN
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible
|
||||
*
|
||||
IF( N.EQ.0 ) THEN
|
||||
WORK( 1 ) = 1
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
NX = N
|
||||
IWS = 1
|
||||
IF( NB.GT.1 .AND. NB.LT.N ) THEN
|
||||
*
|
||||
* Determine when to cross over from blocked to unblocked code
|
||||
* (last block is always handled by unblocked code).
|
||||
*
|
||||
NX = MAX( NB, ILAENV( 3, 'ZHETRD', UPLO, N, -1, -1, -1 ) )
|
||||
IF( NX.LT.N ) THEN
|
||||
*
|
||||
* Determine if workspace is large enough for blocked code.
|
||||
*
|
||||
LDWORK = N
|
||||
IWS = LDWORK*NB
|
||||
IF( LWORK.LT.IWS ) THEN
|
||||
*
|
||||
* Not enough workspace to use optimal NB: determine the
|
||||
* minimum value of NB, and reduce NB or force use of
|
||||
* unblocked code by setting NX = N.
|
||||
*
|
||||
NB = MAX( LWORK / LDWORK, 1 )
|
||||
NBMIN = ILAENV( 2, 'ZHETRD', UPLO, N, -1, -1, -1 )
|
||||
IF( NB.LT.NBMIN )
|
||||
$ NX = N
|
||||
END IF
|
||||
ELSE
|
||||
NX = N
|
||||
END IF
|
||||
ELSE
|
||||
NB = 1
|
||||
END IF
|
||||
*
|
||||
IF( UPPER ) THEN
|
||||
*
|
||||
* Reduce the upper triangle of A.
|
||||
* Columns 1:kk are handled by the unblocked method.
|
||||
*
|
||||
KK = N - ( ( N-NX+NB-1 ) / NB )*NB
|
||||
DO 20 I = N - NB + 1, KK + 1, -NB
|
||||
*
|
||||
* Reduce columns i:i+nb-1 to tridiagonal form and form the
|
||||
* matrix W which is needed to update the unreduced part of
|
||||
* the matrix
|
||||
*
|
||||
CALL ZLATRD( UPLO, I+NB-1, NB, A, LDA, E, TAU, WORK,
|
||||
$ LDWORK )
|
||||
*
|
||||
* Update the unreduced submatrix A(1:i-1,1:i-1), using an
|
||||
* update of the form: A := A - V*W**H - W*V**H
|
||||
*
|
||||
CALL ZHER2K( UPLO, 'No transpose', I-1, NB, -CONE,
|
||||
$ A( 1, I ), LDA, WORK, LDWORK, ONE, A, LDA )
|
||||
*
|
||||
* Copy superdiagonal elements back into A, and diagonal
|
||||
* elements into D
|
||||
*
|
||||
DO 10 J = I, I + NB - 1
|
||||
A( J-1, J ) = E( J-1 )
|
||||
D( J ) = A( J, J )
|
||||
10 CONTINUE
|
||||
20 CONTINUE
|
||||
*
|
||||
* Use unblocked code to reduce the last or only block
|
||||
*
|
||||
CALL ZHETD2( UPLO, KK, A, LDA, D, E, TAU, IINFO )
|
||||
ELSE
|
||||
*
|
||||
* Reduce the lower triangle of A
|
||||
*
|
||||
DO 40 I = 1, N - NX, NB
|
||||
*
|
||||
* Reduce columns i:i+nb-1 to tridiagonal form and form the
|
||||
* matrix W which is needed to update the unreduced part of
|
||||
* the matrix
|
||||
*
|
||||
CALL ZLATRD( UPLO, N-I+1, NB, A( I, I ), LDA, E( I ),
|
||||
$ TAU( I ), WORK, LDWORK )
|
||||
*
|
||||
* Update the unreduced submatrix A(i+nb:n,i+nb:n), using
|
||||
* an update of the form: A := A - V*W**H - W*V**H
|
||||
*
|
||||
CALL ZHER2K( UPLO, 'No transpose', N-I-NB+1, NB, -CONE,
|
||||
$ A( I+NB, I ), LDA, WORK( NB+1 ), LDWORK, ONE,
|
||||
$ A( I+NB, I+NB ), LDA )
|
||||
*
|
||||
* Copy subdiagonal elements back into A, and diagonal
|
||||
* elements into D
|
||||
*
|
||||
DO 30 J = I, I + NB - 1
|
||||
A( J+1, J ) = E( J )
|
||||
D( J ) = A( J, J )
|
||||
30 CONTINUE
|
||||
40 CONTINUE
|
||||
*
|
||||
* Use unblocked code to reduce the last or only block
|
||||
*
|
||||
CALL ZHETD2( UPLO, N-I+1, A( I, I ), LDA, D( I ), E( I ),
|
||||
$ TAU( I ), IINFO )
|
||||
END IF
|
||||
*
|
||||
WORK( 1 ) = LWKOPT
|
||||
RETURN
|
||||
*
|
||||
* End of ZHETRD
|
||||
*
|
||||
END
|
||||
116
lib/linalg/zlacgv.f
Normal file
116
lib/linalg/zlacgv.f
Normal file
@ -0,0 +1,116 @@
|
||||
*> \brief \b ZLACGV conjugates a complex vector.
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
*> \htmlonly
|
||||
*> Download ZLACGV + dependencies
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlacgv.f">
|
||||
*> [TGZ]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlacgv.f">
|
||||
*> [ZIP]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlacgv.f">
|
||||
*> [TXT]</a>
|
||||
*> \endhtmlonly
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE ZLACGV( N, X, INCX )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER INCX, N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* COMPLEX*16 X( * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> ZLACGV conjugates a complex vector of length N.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> The length of the vector X. N >= 0.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] X
|
||||
*> \verbatim
|
||||
*> X is COMPLEX*16 array, dimension
|
||||
*> (1+(N-1)*abs(INCX))
|
||||
*> On entry, the vector of length N to be conjugated.
|
||||
*> On exit, X is overwritten with conjg(X).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] INCX
|
||||
*> \verbatim
|
||||
*> INCX is INTEGER
|
||||
*> The spacing between successive elements of X.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date September 2012
|
||||
*
|
||||
*> \ingroup complex16OTHERauxiliary
|
||||
*
|
||||
* =====================================================================
|
||||
SUBROUTINE ZLACGV( N, X, INCX )
|
||||
*
|
||||
* -- LAPACK auxiliary routine (version 3.4.2) --
|
||||
* -- 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 ..
|
||||
INTEGER INCX, N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
COMPLEX*16 X( * )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Local Scalars ..
|
||||
INTEGER I, IOFF
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC DCONJG
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
IF( INCX.EQ.1 ) THEN
|
||||
DO 10 I = 1, N
|
||||
X( I ) = DCONJG( X( I ) )
|
||||
10 CONTINUE
|
||||
ELSE
|
||||
IOFF = 1
|
||||
IF( INCX.LT.0 )
|
||||
$ IOFF = 1 - ( N-1 )*INCX
|
||||
DO 20 I = 1, N
|
||||
X( IOFF ) = DCONJG( X( IOFF ) )
|
||||
IOFF = IOFF + INCX
|
||||
20 CONTINUE
|
||||
END IF
|
||||
RETURN
|
||||
*
|
||||
* End of ZLACGV
|
||||
*
|
||||
END
|
||||
97
lib/linalg/zladiv.f
Normal file
97
lib/linalg/zladiv.f
Normal file
@ -0,0 +1,97 @@
|
||||
*> \brief \b ZLADIV performs complex division in real arithmetic, avoiding unnecessary overflow.
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
*> \htmlonly
|
||||
*> Download ZLADIV + dependencies
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zladiv.f">
|
||||
*> [TGZ]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zladiv.f">
|
||||
*> [ZIP]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zladiv.f">
|
||||
*> [TXT]</a>
|
||||
*> \endhtmlonly
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* COMPLEX*16 FUNCTION ZLADIV( X, Y )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* COMPLEX*16 X, Y
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> ZLADIV := X / Y, where X and Y are complex. The computation of X / Y
|
||||
*> will not overflow on an intermediary step unless the results
|
||||
*> overflows.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] X
|
||||
*> \verbatim
|
||||
*> X is COMPLEX*16
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] Y
|
||||
*> \verbatim
|
||||
*> Y is COMPLEX*16
|
||||
*> The complex scalars X and Y.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date September 2012
|
||||
*
|
||||
*> \ingroup complex16OTHERauxiliary
|
||||
*
|
||||
* =====================================================================
|
||||
COMPLEX*16 FUNCTION ZLADIV( X, Y )
|
||||
*
|
||||
* -- LAPACK auxiliary routine (version 3.4.2) --
|
||||
* -- 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 ..
|
||||
COMPLEX*16 X, Y
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Local Scalars ..
|
||||
DOUBLE PRECISION ZI, ZR
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL DLADIV
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC DBLE, DCMPLX, DIMAG
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
CALL DLADIV( DBLE( X ), DIMAG( X ), DBLE( Y ), DIMAG( Y ), ZR,
|
||||
$ ZI )
|
||||
ZLADIV = DCMPLX( ZR, ZI )
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of ZLADIV
|
||||
*
|
||||
END
|
||||
258
lib/linalg/zlanhe.f
Normal file
258
lib/linalg/zlanhe.f
Normal file
@ -0,0 +1,258 @@
|
||||
*> \brief \b ZLANHE returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a complex Hermitian matrix.
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
*> \htmlonly
|
||||
*> Download ZLANHE + dependencies
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlanhe.f">
|
||||
*> [TGZ]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlanhe.f">
|
||||
*> [ZIP]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlanhe.f">
|
||||
*> [TXT]</a>
|
||||
*> \endhtmlonly
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* DOUBLE PRECISION FUNCTION ZLANHE( NORM, UPLO, N, A, LDA, WORK )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* CHARACTER NORM, UPLO
|
||||
* INTEGER LDA, N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* DOUBLE PRECISION WORK( * )
|
||||
* COMPLEX*16 A( LDA, * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> ZLANHE returns the value of the one norm, or the Frobenius norm, or
|
||||
*> the infinity norm, or the element of largest absolute value of a
|
||||
*> complex hermitian matrix A.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \return ZLANHE
|
||||
*> \verbatim
|
||||
*>
|
||||
*> ZLANHE = ( max(abs(A(i,j))), NORM = 'M' or 'm'
|
||||
*> (
|
||||
*> ( norm1(A), NORM = '1', 'O' or 'o'
|
||||
*> (
|
||||
*> ( normI(A), NORM = 'I' or 'i'
|
||||
*> (
|
||||
*> ( normF(A), NORM = 'F', 'f', 'E' or 'e'
|
||||
*>
|
||||
*> where norm1 denotes the one norm of a matrix (maximum column sum),
|
||||
*> normI denotes the infinity norm of a matrix (maximum row sum) and
|
||||
*> normF denotes the Frobenius norm of a matrix (square root of sum of
|
||||
*> squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] NORM
|
||||
*> \verbatim
|
||||
*> NORM is CHARACTER*1
|
||||
*> Specifies the value to be returned in ZLANHE as described
|
||||
*> above.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] UPLO
|
||||
*> \verbatim
|
||||
*> UPLO is CHARACTER*1
|
||||
*> Specifies whether the upper or lower triangular part of the
|
||||
*> hermitian matrix A is to be referenced.
|
||||
*> = 'U': Upper triangular part of A is referenced
|
||||
*> = 'L': Lower triangular part of A is referenced
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> The order of the matrix A. N >= 0. When N = 0, ZLANHE is
|
||||
*> set to zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] A
|
||||
*> \verbatim
|
||||
*> A is COMPLEX*16 array, dimension (LDA,N)
|
||||
*> The hermitian matrix A. If UPLO = 'U', the leading n by n
|
||||
*> upper triangular part of A contains the upper triangular part
|
||||
*> of the matrix A, and the strictly lower triangular part of A
|
||||
*> is not referenced. If UPLO = 'L', the leading n by n lower
|
||||
*> triangular part of A contains the lower triangular part of
|
||||
*> the matrix A, and the strictly upper triangular part of A is
|
||||
*> not referenced. Note that the imaginary parts of the diagonal
|
||||
*> elements need not be set and are assumed to be zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> The leading dimension of the array A. LDA >= max(N,1).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] WORK
|
||||
*> \verbatim
|
||||
*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)),
|
||||
*> where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,
|
||||
*> WORK is not referenced.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date September 2012
|
||||
*
|
||||
*> \ingroup complex16HEauxiliary
|
||||
*
|
||||
* =====================================================================
|
||||
DOUBLE PRECISION FUNCTION ZLANHE( NORM, UPLO, N, A, LDA, WORK )
|
||||
*
|
||||
* -- LAPACK auxiliary routine (version 3.4.2) --
|
||||
* -- 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 ..
|
||||
CHARACTER NORM, UPLO
|
||||
INTEGER LDA, N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION WORK( * )
|
||||
COMPLEX*16 A( LDA, * )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
DOUBLE PRECISION ONE, ZERO
|
||||
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
INTEGER I, J
|
||||
DOUBLE PRECISION ABSA, SCALE, SUM, VALUE
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME, DISNAN
|
||||
EXTERNAL LSAME, DISNAN
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL ZLASSQ
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC ABS, DBLE, SQRT
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
IF( N.EQ.0 ) THEN
|
||||
VALUE = ZERO
|
||||
ELSE IF( LSAME( NORM, 'M' ) ) THEN
|
||||
*
|
||||
* Find max(abs(A(i,j))).
|
||||
*
|
||||
VALUE = ZERO
|
||||
IF( LSAME( UPLO, 'U' ) ) THEN
|
||||
DO 20 J = 1, N
|
||||
DO 10 I = 1, J - 1
|
||||
SUM = ABS( A( I, J ) )
|
||||
IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM
|
||||
10 CONTINUE
|
||||
SUM = ABS( DBLE( A( J, J ) ) )
|
||||
IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM
|
||||
20 CONTINUE
|
||||
ELSE
|
||||
DO 40 J = 1, N
|
||||
SUM = ABS( DBLE( A( J, J ) ) )
|
||||
IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM
|
||||
DO 30 I = J + 1, N
|
||||
SUM = ABS( A( I, J ) )
|
||||
IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM
|
||||
30 CONTINUE
|
||||
40 CONTINUE
|
||||
END IF
|
||||
ELSE IF( ( LSAME( NORM, 'I' ) ) .OR. ( LSAME( NORM, 'O' ) ) .OR.
|
||||
$ ( NORM.EQ.'1' ) ) THEN
|
||||
*
|
||||
* Find normI(A) ( = norm1(A), since A is hermitian).
|
||||
*
|
||||
VALUE = ZERO
|
||||
IF( LSAME( UPLO, 'U' ) ) THEN
|
||||
DO 60 J = 1, N
|
||||
SUM = ZERO
|
||||
DO 50 I = 1, J - 1
|
||||
ABSA = ABS( A( I, J ) )
|
||||
SUM = SUM + ABSA
|
||||
WORK( I ) = WORK( I ) + ABSA
|
||||
50 CONTINUE
|
||||
WORK( J ) = SUM + ABS( DBLE( A( J, J ) ) )
|
||||
60 CONTINUE
|
||||
DO 70 I = 1, N
|
||||
SUM = WORK( I )
|
||||
IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM
|
||||
70 CONTINUE
|
||||
ELSE
|
||||
DO 80 I = 1, N
|
||||
WORK( I ) = ZERO
|
||||
80 CONTINUE
|
||||
DO 100 J = 1, N
|
||||
SUM = WORK( J ) + ABS( DBLE( A( J, J ) ) )
|
||||
DO 90 I = J + 1, N
|
||||
ABSA = ABS( A( I, J ) )
|
||||
SUM = SUM + ABSA
|
||||
WORK( I ) = WORK( I ) + ABSA
|
||||
90 CONTINUE
|
||||
IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM
|
||||
100 CONTINUE
|
||||
END IF
|
||||
ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
|
||||
*
|
||||
* Find normF(A).
|
||||
*
|
||||
SCALE = ZERO
|
||||
SUM = ONE
|
||||
IF( LSAME( UPLO, 'U' ) ) THEN
|
||||
DO 110 J = 2, N
|
||||
CALL ZLASSQ( J-1, A( 1, J ), 1, SCALE, SUM )
|
||||
110 CONTINUE
|
||||
ELSE
|
||||
DO 120 J = 1, N - 1
|
||||
CALL ZLASSQ( N-J, A( J+1, J ), 1, SCALE, SUM )
|
||||
120 CONTINUE
|
||||
END IF
|
||||
SUM = 2*SUM
|
||||
DO 130 I = 1, N
|
||||
IF( DBLE( A( I, I ) ).NE.ZERO ) THEN
|
||||
ABSA = ABS( DBLE( A( I, I ) ) )
|
||||
IF( SCALE.LT.ABSA ) THEN
|
||||
SUM = ONE + SUM*( SCALE / ABSA )**2
|
||||
SCALE = ABSA
|
||||
ELSE
|
||||
SUM = SUM + ( ABSA / SCALE )**2
|
||||
END IF
|
||||
END IF
|
||||
130 CONTINUE
|
||||
VALUE = SCALE*SQRT( SUM )
|
||||
END IF
|
||||
*
|
||||
ZLANHE = VALUE
|
||||
RETURN
|
||||
*
|
||||
* End of ZLANHE
|
||||
*
|
||||
END
|
||||
232
lib/linalg/zlarf.f
Normal file
232
lib/linalg/zlarf.f
Normal file
@ -0,0 +1,232 @@
|
||||
*> \brief \b ZLARF applies an elementary reflector to a general rectangular matrix.
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
*> \htmlonly
|
||||
*> Download ZLARF + dependencies
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlarf.f">
|
||||
*> [TGZ]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlarf.f">
|
||||
*> [ZIP]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlarf.f">
|
||||
*> [TXT]</a>
|
||||
*> \endhtmlonly
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE ZLARF( 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
|
||||
*>
|
||||
*> ZLARF 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.
|
||||
*>
|
||||
*> 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
|
||||
*> = '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.
|
||||
*
|
||||
*> \date September 2012
|
||||
*
|
||||
*> \ingroup complex16OTHERauxiliary
|
||||
*
|
||||
* =====================================================================
|
||||
SUBROUTINE ZLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )
|
||||
*
|
||||
* -- LAPACK auxiliary routine (version 3.4.2) --
|
||||
* -- 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 ..
|
||||
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
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL ZGEMV, ZGERC
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
INTEGER ILAZLR, ILAZLC
|
||||
EXTERNAL LSAME, ILAZLR, ILAZLC
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
APPLYLEFT = LSAME( SIDE, 'L' )
|
||||
LASTV = 0
|
||||
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.
|
||||
DO WHILE( LASTV.GT.0 .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
|
||||
* Note that lastc.eq.0 renders the BLAS operations null; no special
|
||||
* case is needed at this level.
|
||||
IF( APPLYLEFT ) THEN
|
||||
*
|
||||
* Form H * C
|
||||
*
|
||||
IF( LASTV.GT.0 ) THEN
|
||||
*
|
||||
* w(1:lastc,1) := C(1:lastv,1:lastc)**H * v(1:lastv,1)
|
||||
*
|
||||
CALL ZGEMV( 'Conjugate transpose', LASTV, LASTC, ONE,
|
||||
$ C, LDC, V, INCV, ZERO, WORK, 1 )
|
||||
*
|
||||
* C(1:lastv,1:lastc) := C(...) - v(1:lastv,1) * w(1:lastc,1)**H
|
||||
*
|
||||
CALL ZGERC( LASTV, LASTC, -TAU, V, INCV, WORK, 1, C, LDC )
|
||||
END IF
|
||||
ELSE
|
||||
*
|
||||
* Form C * H
|
||||
*
|
||||
IF( LASTV.GT.0 ) THEN
|
||||
*
|
||||
* w(1:lastc,1) := C(1:lastc,1:lastv) * v(1:lastv,1)
|
||||
*
|
||||
CALL ZGEMV( 'No transpose', LASTC, LASTV, ONE, C, LDC,
|
||||
$ V, INCV, ZERO, WORK, 1 )
|
||||
*
|
||||
* C(1:lastc,1:lastv) := C(...) - w(1:lastc,1) * v(1:lastv,1)**H
|
||||
*
|
||||
CALL ZGERC( LASTC, LASTV, -TAU, WORK, 1, V, INCV, C, LDC )
|
||||
END IF
|
||||
END IF
|
||||
RETURN
|
||||
*
|
||||
* End of ZLARF
|
||||
*
|
||||
END
|
||||
769
lib/linalg/zlarfb.f
Normal file
769
lib/linalg/zlarfb.f
Normal file
@ -0,0 +1,769 @@
|
||||
*> \brief \b ZLARFB applies a block reflector or its conjugate-transpose to a general rectangular matrix.
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
*> \htmlonly
|
||||
*> Download ZLARFB + dependencies
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlarfb.f">
|
||||
*> [TGZ]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlarfb.f">
|
||||
*> [ZIP]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlarfb.f">
|
||||
*> [TXT]</a>
|
||||
*> \endhtmlonly
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE ZLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV,
|
||||
* T, LDT, C, LDC, WORK, LDWORK )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* CHARACTER DIRECT, SIDE, STOREV, TRANS
|
||||
* INTEGER K, LDC, LDT, LDV, LDWORK, M, N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* COMPLEX*16 C( LDC, * ), T( LDT, * ), V( LDV, * ),
|
||||
* $ WORK( LDWORK, * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> ZLARFB applies a complex block reflector H or its transpose H**H to a
|
||||
*> complex M-by-N matrix C, from either the left or the right.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] SIDE
|
||||
*> \verbatim
|
||||
*> SIDE is CHARACTER*1
|
||||
*> = 'L': apply H or H**H from the Left
|
||||
*> = 'R': apply H or H**H from the Right
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] TRANS
|
||||
*> \verbatim
|
||||
*> TRANS is CHARACTER*1
|
||||
*> = 'N': apply H (No transpose)
|
||||
*> = 'C': apply H**H (Conjugate transpose)
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] DIRECT
|
||||
*> \verbatim
|
||||
*> DIRECT is CHARACTER*1
|
||||
*> Indicates how H is formed from a product of elementary
|
||||
*> reflectors
|
||||
*> = 'F': H = H(1) H(2) . . . H(k) (Forward)
|
||||
*> = 'B': H = H(k) . . . H(2) H(1) (Backward)
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] STOREV
|
||||
*> \verbatim
|
||||
*> STOREV is CHARACTER*1
|
||||
*> Indicates how the vectors which define the elementary
|
||||
*> reflectors are stored:
|
||||
*> = 'C': Columnwise
|
||||
*> = 'R': Rowwise
|
||||
*> \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] K
|
||||
*> \verbatim
|
||||
*> K is INTEGER
|
||||
*> The order of the matrix T (= the number of elementary
|
||||
*> reflectors whose product defines the block reflector).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] V
|
||||
*> \verbatim
|
||||
*> V is COMPLEX*16 array, dimension
|
||||
*> (LDV,K) if STOREV = 'C'
|
||||
*> (LDV,M) if STOREV = 'R' and SIDE = 'L'
|
||||
*> (LDV,N) if STOREV = 'R' and SIDE = 'R'
|
||||
*> See Further Details.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDV
|
||||
*> \verbatim
|
||||
*> LDV is INTEGER
|
||||
*> The leading dimension of the array V.
|
||||
*> If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M);
|
||||
*> if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N);
|
||||
*> if STOREV = 'R', LDV >= K.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] T
|
||||
*> \verbatim
|
||||
*> T is COMPLEX*16 array, dimension (LDT,K)
|
||||
*> The triangular K-by-K matrix T in the representation of the
|
||||
*> block reflector.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDT
|
||||
*> \verbatim
|
||||
*> LDT is INTEGER
|
||||
*> The leading dimension of the array T. LDT >= K.
|
||||
*> \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 H*C or H**H*C or C*H or C*H**H.
|
||||
*> \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 (LDWORK,K)
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDWORK
|
||||
*> \verbatim
|
||||
*> LDWORK is INTEGER
|
||||
*> The leading dimension of the array WORK.
|
||||
*> If SIDE = 'L', LDWORK >= max(1,N);
|
||||
*> if SIDE = 'R', LDWORK >= max(1,M).
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date September 2012
|
||||
*
|
||||
*> \ingroup complex16OTHERauxiliary
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> The shape of the matrix V and the storage of the vectors which define
|
||||
*> the H(i) is best illustrated by the following example with n = 5 and
|
||||
*> k = 3. The elements equal to 1 are not stored; the corresponding
|
||||
*> array elements are modified but restored on exit. The rest of the
|
||||
*> array is not used.
|
||||
*>
|
||||
*> DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R':
|
||||
*>
|
||||
*> V = ( 1 ) V = ( 1 v1 v1 v1 v1 )
|
||||
*> ( v1 1 ) ( 1 v2 v2 v2 )
|
||||
*> ( v1 v2 1 ) ( 1 v3 v3 )
|
||||
*> ( v1 v2 v3 )
|
||||
*> ( v1 v2 v3 )
|
||||
*>
|
||||
*> DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R':
|
||||
*>
|
||||
*> V = ( v1 v2 v3 ) V = ( v1 v1 1 )
|
||||
*> ( v1 v2 v3 ) ( v2 v2 v2 1 )
|
||||
*> ( 1 v2 v3 ) ( v3 v3 v3 v3 1 )
|
||||
*> ( 1 v3 )
|
||||
*> ( 1 )
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
SUBROUTINE ZLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV,
|
||||
$ T, LDT, C, LDC, WORK, LDWORK )
|
||||
*
|
||||
* -- LAPACK auxiliary routine (version 3.4.2) --
|
||||
* -- 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 ..
|
||||
CHARACTER DIRECT, SIDE, STOREV, TRANS
|
||||
INTEGER K, LDC, LDT, LDV, LDWORK, M, N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
COMPLEX*16 C( LDC, * ), T( LDT, * ), V( LDV, * ),
|
||||
$ WORK( LDWORK, * )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
COMPLEX*16 ONE
|
||||
PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
CHARACTER TRANST
|
||||
INTEGER I, J, LASTV, LASTC
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
INTEGER ILAZLR, ILAZLC
|
||||
EXTERNAL LSAME, ILAZLR, ILAZLC
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL ZCOPY, ZGEMM, ZLACGV, ZTRMM
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC DCONJG
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* Quick return if possible
|
||||
*
|
||||
IF( M.LE.0 .OR. N.LE.0 )
|
||||
$ RETURN
|
||||
*
|
||||
IF( LSAME( TRANS, 'N' ) ) THEN
|
||||
TRANST = 'C'
|
||||
ELSE
|
||||
TRANST = 'N'
|
||||
END IF
|
||||
*
|
||||
IF( LSAME( STOREV, 'C' ) ) THEN
|
||||
*
|
||||
IF( LSAME( DIRECT, 'F' ) ) THEN
|
||||
*
|
||||
* Let V = ( V1 ) (first K rows)
|
||||
* ( V2 )
|
||||
* where V1 is unit lower triangular.
|
||||
*
|
||||
IF( LSAME( SIDE, 'L' ) ) THEN
|
||||
*
|
||||
* Form H * C or H**H * C where C = ( C1 )
|
||||
* ( C2 )
|
||||
*
|
||||
LASTV = MAX( K, ILAZLR( M, K, V, LDV ) )
|
||||
LASTC = ILAZLC( LASTV, N, C, LDC )
|
||||
*
|
||||
* W := C**H * V = (C1**H * V1 + C2**H * V2) (stored in WORK)
|
||||
*
|
||||
* W := C1**H
|
||||
*
|
||||
DO 10 J = 1, K
|
||||
CALL ZCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 )
|
||||
CALL ZLACGV( LASTC, WORK( 1, J ), 1 )
|
||||
10 CONTINUE
|
||||
*
|
||||
* W := W * V1
|
||||
*
|
||||
CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit',
|
||||
$ LASTC, K, ONE, V, LDV, WORK, LDWORK )
|
||||
IF( LASTV.GT.K ) THEN
|
||||
*
|
||||
* W := W + C2**H *V2
|
||||
*
|
||||
CALL ZGEMM( 'Conjugate transpose', 'No transpose',
|
||||
$ LASTC, K, LASTV-K, ONE, C( K+1, 1 ), LDC,
|
||||
$ V( K+1, 1 ), LDV, ONE, WORK, LDWORK )
|
||||
END IF
|
||||
*
|
||||
* W := W * T**H or W * T
|
||||
*
|
||||
CALL ZTRMM( 'Right', 'Upper', TRANST, 'Non-unit',
|
||||
$ LASTC, K, ONE, T, LDT, WORK, LDWORK )
|
||||
*
|
||||
* C := C - V * W**H
|
||||
*
|
||||
IF( M.GT.K ) THEN
|
||||
*
|
||||
* C2 := C2 - V2 * W**H
|
||||
*
|
||||
CALL ZGEMM( 'No transpose', 'Conjugate transpose',
|
||||
$ LASTV-K, LASTC, K,
|
||||
$ -ONE, V( K+1, 1 ), LDV, WORK, LDWORK,
|
||||
$ ONE, C( K+1, 1 ), LDC )
|
||||
END IF
|
||||
*
|
||||
* W := W * V1**H
|
||||
*
|
||||
CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose',
|
||||
$ 'Unit', LASTC, K, ONE, V, LDV, WORK, LDWORK )
|
||||
*
|
||||
* C1 := C1 - W**H
|
||||
*
|
||||
DO 30 J = 1, K
|
||||
DO 20 I = 1, LASTC
|
||||
C( J, I ) = C( J, I ) - DCONJG( WORK( I, J ) )
|
||||
20 CONTINUE
|
||||
30 CONTINUE
|
||||
*
|
||||
ELSE IF( LSAME( SIDE, 'R' ) ) THEN
|
||||
*
|
||||
* Form C * H or C * H**H where C = ( C1 C2 )
|
||||
*
|
||||
LASTV = MAX( K, ILAZLR( N, K, V, LDV ) )
|
||||
LASTC = ILAZLR( M, LASTV, C, LDC )
|
||||
*
|
||||
* W := C * V = (C1*V1 + C2*V2) (stored in WORK)
|
||||
*
|
||||
* W := C1
|
||||
*
|
||||
DO 40 J = 1, K
|
||||
CALL ZCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 )
|
||||
40 CONTINUE
|
||||
*
|
||||
* W := W * V1
|
||||
*
|
||||
CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit',
|
||||
$ LASTC, K, ONE, V, LDV, WORK, LDWORK )
|
||||
IF( LASTV.GT.K ) THEN
|
||||
*
|
||||
* W := W + C2 * V2
|
||||
*
|
||||
CALL ZGEMM( 'No transpose', 'No transpose',
|
||||
$ LASTC, K, LASTV-K,
|
||||
$ ONE, C( 1, K+1 ), LDC, V( K+1, 1 ), LDV,
|
||||
$ ONE, WORK, LDWORK )
|
||||
END IF
|
||||
*
|
||||
* W := W * T or W * T**H
|
||||
*
|
||||
CALL ZTRMM( 'Right', 'Upper', TRANS, 'Non-unit',
|
||||
$ LASTC, K, ONE, T, LDT, WORK, LDWORK )
|
||||
*
|
||||
* C := C - W * V**H
|
||||
*
|
||||
IF( LASTV.GT.K ) THEN
|
||||
*
|
||||
* C2 := C2 - W * V2**H
|
||||
*
|
||||
CALL ZGEMM( 'No transpose', 'Conjugate transpose',
|
||||
$ LASTC, LASTV-K, K,
|
||||
$ -ONE, WORK, LDWORK, V( K+1, 1 ), LDV,
|
||||
$ ONE, C( 1, K+1 ), LDC )
|
||||
END IF
|
||||
*
|
||||
* W := W * V1**H
|
||||
*
|
||||
CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose',
|
||||
$ 'Unit', LASTC, K, ONE, V, LDV, WORK, LDWORK )
|
||||
*
|
||||
* C1 := C1 - W
|
||||
*
|
||||
DO 60 J = 1, K
|
||||
DO 50 I = 1, LASTC
|
||||
C( I, J ) = C( I, J ) - WORK( I, J )
|
||||
50 CONTINUE
|
||||
60 CONTINUE
|
||||
END IF
|
||||
*
|
||||
ELSE
|
||||
*
|
||||
* Let V = ( V1 )
|
||||
* ( V2 ) (last K rows)
|
||||
* where V2 is unit upper triangular.
|
||||
*
|
||||
IF( LSAME( SIDE, 'L' ) ) THEN
|
||||
*
|
||||
* Form H * C or H**H * C where C = ( C1 )
|
||||
* ( C2 )
|
||||
*
|
||||
LASTC = ILAZLC( M, N, C, LDC )
|
||||
*
|
||||
* W := C**H * V = (C1**H * V1 + C2**H * V2) (stored in WORK)
|
||||
*
|
||||
* W := C2**H
|
||||
*
|
||||
DO 70 J = 1, K
|
||||
CALL ZCOPY( LASTC, C( M-K+J, 1 ), LDC,
|
||||
$ WORK( 1, J ), 1 )
|
||||
CALL ZLACGV( LASTC, WORK( 1, J ), 1 )
|
||||
70 CONTINUE
|
||||
*
|
||||
* W := W * V2
|
||||
*
|
||||
CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit',
|
||||
$ LASTC, K, ONE, V( M-K+1, 1 ), LDV,
|
||||
$ WORK, LDWORK )
|
||||
IF( M.GT.K ) THEN
|
||||
*
|
||||
* W := W + C1**H*V1
|
||||
*
|
||||
CALL ZGEMM( 'Conjugate transpose', 'No transpose',
|
||||
$ LASTC, K, M-K,
|
||||
$ ONE, C, LDC, V, LDV,
|
||||
$ ONE, WORK, LDWORK )
|
||||
END IF
|
||||
*
|
||||
* W := W * T**H or W * T
|
||||
*
|
||||
CALL ZTRMM( 'Right', 'Lower', TRANST, 'Non-unit',
|
||||
$ LASTC, K, ONE, T, LDT, WORK, LDWORK )
|
||||
*
|
||||
* C := C - V * W**H
|
||||
*
|
||||
IF( M.GT.K ) THEN
|
||||
*
|
||||
* C1 := C1 - V1 * W**H
|
||||
*
|
||||
CALL ZGEMM( 'No transpose', 'Conjugate transpose',
|
||||
$ M-K, LASTC, K,
|
||||
$ -ONE, V, LDV, WORK, LDWORK,
|
||||
$ ONE, C, LDC )
|
||||
END IF
|
||||
*
|
||||
* W := W * V2**H
|
||||
*
|
||||
CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose',
|
||||
$ 'Unit', LASTC, K, ONE, V( M-K+1, 1 ), LDV,
|
||||
$ WORK, LDWORK )
|
||||
*
|
||||
* C2 := C2 - W**H
|
||||
*
|
||||
DO 90 J = 1, K
|
||||
DO 80 I = 1, LASTC
|
||||
C( M-K+J, I ) = C( M-K+J, I ) -
|
||||
$ DCONJG( WORK( I, J ) )
|
||||
80 CONTINUE
|
||||
90 CONTINUE
|
||||
*
|
||||
ELSE IF( LSAME( SIDE, 'R' ) ) THEN
|
||||
*
|
||||
* Form C * H or C * H**H where C = ( C1 C2 )
|
||||
*
|
||||
LASTC = ILAZLR( M, N, C, LDC )
|
||||
*
|
||||
* W := C * V = (C1*V1 + C2*V2) (stored in WORK)
|
||||
*
|
||||
* W := C2
|
||||
*
|
||||
DO 100 J = 1, K
|
||||
CALL ZCOPY( LASTC, C( 1, N-K+J ), 1,
|
||||
$ WORK( 1, J ), 1 )
|
||||
100 CONTINUE
|
||||
*
|
||||
* W := W * V2
|
||||
*
|
||||
CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit',
|
||||
$ LASTC, K, ONE, V( N-K+1, 1 ), LDV,
|
||||
$ WORK, LDWORK )
|
||||
IF( N.GT.K ) THEN
|
||||
*
|
||||
* W := W + C1 * V1
|
||||
*
|
||||
CALL ZGEMM( 'No transpose', 'No transpose',
|
||||
$ LASTC, K, N-K,
|
||||
$ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK )
|
||||
END IF
|
||||
*
|
||||
* W := W * T or W * T**H
|
||||
*
|
||||
CALL ZTRMM( 'Right', 'Lower', TRANS, 'Non-unit',
|
||||
$ LASTC, K, ONE, T, LDT, WORK, LDWORK )
|
||||
*
|
||||
* C := C - W * V**H
|
||||
*
|
||||
IF( N.GT.K ) THEN
|
||||
*
|
||||
* C1 := C1 - W * V1**H
|
||||
*
|
||||
CALL ZGEMM( 'No transpose', 'Conjugate transpose',
|
||||
$ LASTC, N-K, K, -ONE, WORK, LDWORK, V, LDV,
|
||||
$ ONE, C, LDC )
|
||||
END IF
|
||||
*
|
||||
* W := W * V2**H
|
||||
*
|
||||
CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose',
|
||||
$ 'Unit', LASTC, K, ONE, V( N-K+1, 1 ), LDV,
|
||||
$ WORK, LDWORK )
|
||||
*
|
||||
* C2 := C2 - W
|
||||
*
|
||||
DO 120 J = 1, K
|
||||
DO 110 I = 1, LASTC
|
||||
C( I, N-K+J ) = C( I, N-K+J )
|
||||
$ - WORK( I, J )
|
||||
110 CONTINUE
|
||||
120 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
ELSE IF( LSAME( STOREV, 'R' ) ) THEN
|
||||
*
|
||||
IF( LSAME( DIRECT, 'F' ) ) THEN
|
||||
*
|
||||
* Let V = ( V1 V2 ) (V1: first K columns)
|
||||
* where V1 is unit upper triangular.
|
||||
*
|
||||
IF( LSAME( SIDE, 'L' ) ) THEN
|
||||
*
|
||||
* Form H * C or H**H * C where C = ( C1 )
|
||||
* ( C2 )
|
||||
*
|
||||
LASTV = MAX( K, ILAZLC( K, M, V, LDV ) )
|
||||
LASTC = ILAZLC( LASTV, N, C, LDC )
|
||||
*
|
||||
* W := C**H * V**H = (C1**H * V1**H + C2**H * V2**H) (stored in WORK)
|
||||
*
|
||||
* W := C1**H
|
||||
*
|
||||
DO 130 J = 1, K
|
||||
CALL ZCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 )
|
||||
CALL ZLACGV( LASTC, WORK( 1, J ), 1 )
|
||||
130 CONTINUE
|
||||
*
|
||||
* W := W * V1**H
|
||||
*
|
||||
CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose',
|
||||
$ 'Unit', LASTC, K, ONE, V, LDV, WORK, LDWORK )
|
||||
IF( LASTV.GT.K ) THEN
|
||||
*
|
||||
* W := W + C2**H*V2**H
|
||||
*
|
||||
CALL ZGEMM( 'Conjugate transpose',
|
||||
$ 'Conjugate transpose', LASTC, K, LASTV-K,
|
||||
$ ONE, C( K+1, 1 ), LDC, V( 1, K+1 ), LDV,
|
||||
$ ONE, WORK, LDWORK )
|
||||
END IF
|
||||
*
|
||||
* W := W * T**H or W * T
|
||||
*
|
||||
CALL ZTRMM( 'Right', 'Upper', TRANST, 'Non-unit',
|
||||
$ LASTC, K, ONE, T, LDT, WORK, LDWORK )
|
||||
*
|
||||
* C := C - V**H * W**H
|
||||
*
|
||||
IF( LASTV.GT.K ) THEN
|
||||
*
|
||||
* C2 := C2 - V2**H * W**H
|
||||
*
|
||||
CALL ZGEMM( 'Conjugate transpose',
|
||||
$ 'Conjugate transpose', LASTV-K, LASTC, K,
|
||||
$ -ONE, V( 1, K+1 ), LDV, WORK, LDWORK,
|
||||
$ ONE, C( K+1, 1 ), LDC )
|
||||
END IF
|
||||
*
|
||||
* W := W * V1
|
||||
*
|
||||
CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit',
|
||||
$ LASTC, K, ONE, V, LDV, WORK, LDWORK )
|
||||
*
|
||||
* C1 := C1 - W**H
|
||||
*
|
||||
DO 150 J = 1, K
|
||||
DO 140 I = 1, LASTC
|
||||
C( J, I ) = C( J, I ) - DCONJG( WORK( I, J ) )
|
||||
140 CONTINUE
|
||||
150 CONTINUE
|
||||
*
|
||||
ELSE IF( LSAME( SIDE, 'R' ) ) THEN
|
||||
*
|
||||
* Form C * H or C * H**H where C = ( C1 C2 )
|
||||
*
|
||||
LASTV = MAX( K, ILAZLC( K, N, V, LDV ) )
|
||||
LASTC = ILAZLR( M, LASTV, C, LDC )
|
||||
*
|
||||
* W := C * V**H = (C1*V1**H + C2*V2**H) (stored in WORK)
|
||||
*
|
||||
* W := C1
|
||||
*
|
||||
DO 160 J = 1, K
|
||||
CALL ZCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 )
|
||||
160 CONTINUE
|
||||
*
|
||||
* W := W * V1**H
|
||||
*
|
||||
CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose',
|
||||
$ 'Unit', LASTC, K, ONE, V, LDV, WORK, LDWORK )
|
||||
IF( LASTV.GT.K ) THEN
|
||||
*
|
||||
* W := W + C2 * V2**H
|
||||
*
|
||||
CALL ZGEMM( 'No transpose', 'Conjugate transpose',
|
||||
$ LASTC, K, LASTV-K, ONE, C( 1, K+1 ), LDC,
|
||||
$ V( 1, K+1 ), LDV, ONE, WORK, LDWORK )
|
||||
END IF
|
||||
*
|
||||
* W := W * T or W * T**H
|
||||
*
|
||||
CALL ZTRMM( 'Right', 'Upper', TRANS, 'Non-unit',
|
||||
$ LASTC, K, ONE, T, LDT, WORK, LDWORK )
|
||||
*
|
||||
* C := C - W * V
|
||||
*
|
||||
IF( LASTV.GT.K ) THEN
|
||||
*
|
||||
* C2 := C2 - W * V2
|
||||
*
|
||||
CALL ZGEMM( 'No transpose', 'No transpose',
|
||||
$ LASTC, LASTV-K, K,
|
||||
$ -ONE, WORK, LDWORK, V( 1, K+1 ), LDV,
|
||||
$ ONE, C( 1, K+1 ), LDC )
|
||||
END IF
|
||||
*
|
||||
* W := W * V1
|
||||
*
|
||||
CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit',
|
||||
$ LASTC, K, ONE, V, LDV, WORK, LDWORK )
|
||||
*
|
||||
* C1 := C1 - W
|
||||
*
|
||||
DO 180 J = 1, K
|
||||
DO 170 I = 1, LASTC
|
||||
C( I, J ) = C( I, J ) - WORK( I, J )
|
||||
170 CONTINUE
|
||||
180 CONTINUE
|
||||
*
|
||||
END IF
|
||||
*
|
||||
ELSE
|
||||
*
|
||||
* Let V = ( V1 V2 ) (V2: last K columns)
|
||||
* where V2 is unit lower triangular.
|
||||
*
|
||||
IF( LSAME( SIDE, 'L' ) ) THEN
|
||||
*
|
||||
* Form H * C or H**H * C where C = ( C1 )
|
||||
* ( C2 )
|
||||
*
|
||||
LASTC = ILAZLC( M, N, C, LDC )
|
||||
*
|
||||
* W := C**H * V**H = (C1**H * V1**H + C2**H * V2**H) (stored in WORK)
|
||||
*
|
||||
* W := C2**H
|
||||
*
|
||||
DO 190 J = 1, K
|
||||
CALL ZCOPY( LASTC, C( M-K+J, 1 ), LDC,
|
||||
$ WORK( 1, J ), 1 )
|
||||
CALL ZLACGV( LASTC, WORK( 1, J ), 1 )
|
||||
190 CONTINUE
|
||||
*
|
||||
* W := W * V2**H
|
||||
*
|
||||
CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose',
|
||||
$ 'Unit', LASTC, K, ONE, V( 1, M-K+1 ), LDV,
|
||||
$ WORK, LDWORK )
|
||||
IF( M.GT.K ) THEN
|
||||
*
|
||||
* W := W + C1**H * V1**H
|
||||
*
|
||||
CALL ZGEMM( 'Conjugate transpose',
|
||||
$ 'Conjugate transpose', LASTC, K, M-K,
|
||||
$ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK )
|
||||
END IF
|
||||
*
|
||||
* W := W * T**H or W * T
|
||||
*
|
||||
CALL ZTRMM( 'Right', 'Lower', TRANST, 'Non-unit',
|
||||
$ LASTC, K, ONE, T, LDT, WORK, LDWORK )
|
||||
*
|
||||
* C := C - V**H * W**H
|
||||
*
|
||||
IF( M.GT.K ) THEN
|
||||
*
|
||||
* C1 := C1 - V1**H * W**H
|
||||
*
|
||||
CALL ZGEMM( 'Conjugate transpose',
|
||||
$ 'Conjugate transpose', M-K, LASTC, K,
|
||||
$ -ONE, V, LDV, WORK, LDWORK, ONE, C, LDC )
|
||||
END IF
|
||||
*
|
||||
* W := W * V2
|
||||
*
|
||||
CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit',
|
||||
$ LASTC, K, ONE, V( 1, M-K+1 ), LDV,
|
||||
$ WORK, LDWORK )
|
||||
*
|
||||
* C2 := C2 - W**H
|
||||
*
|
||||
DO 210 J = 1, K
|
||||
DO 200 I = 1, LASTC
|
||||
C( M-K+J, I ) = C( M-K+J, I ) -
|
||||
$ DCONJG( WORK( I, J ) )
|
||||
200 CONTINUE
|
||||
210 CONTINUE
|
||||
*
|
||||
ELSE IF( LSAME( SIDE, 'R' ) ) THEN
|
||||
*
|
||||
* Form C * H or C * H**H where C = ( C1 C2 )
|
||||
*
|
||||
LASTC = ILAZLR( M, N, C, LDC )
|
||||
*
|
||||
* W := C * V**H = (C1*V1**H + C2*V2**H) (stored in WORK)
|
||||
*
|
||||
* W := C2
|
||||
*
|
||||
DO 220 J = 1, K
|
||||
CALL ZCOPY( LASTC, C( 1, N-K+J ), 1,
|
||||
$ WORK( 1, J ), 1 )
|
||||
220 CONTINUE
|
||||
*
|
||||
* W := W * V2**H
|
||||
*
|
||||
CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose',
|
||||
$ 'Unit', LASTC, K, ONE, V( 1, N-K+1 ), LDV,
|
||||
$ WORK, LDWORK )
|
||||
IF( N.GT.K ) THEN
|
||||
*
|
||||
* W := W + C1 * V1**H
|
||||
*
|
||||
CALL ZGEMM( 'No transpose', 'Conjugate transpose',
|
||||
$ LASTC, K, N-K, ONE, C, LDC, V, LDV, ONE,
|
||||
$ WORK, LDWORK )
|
||||
END IF
|
||||
*
|
||||
* W := W * T or W * T**H
|
||||
*
|
||||
CALL ZTRMM( 'Right', 'Lower', TRANS, 'Non-unit',
|
||||
$ LASTC, K, ONE, T, LDT, WORK, LDWORK )
|
||||
*
|
||||
* C := C - W * V
|
||||
*
|
||||
IF( N.GT.K ) THEN
|
||||
*
|
||||
* C1 := C1 - W * V1
|
||||
*
|
||||
CALL ZGEMM( 'No transpose', 'No transpose',
|
||||
$ LASTC, N-K, K, -ONE, WORK, LDWORK, V, LDV,
|
||||
$ ONE, C, LDC )
|
||||
END IF
|
||||
*
|
||||
* W := W * V2
|
||||
*
|
||||
CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit',
|
||||
$ LASTC, K, ONE, V( 1, N-K+1 ), LDV,
|
||||
$ WORK, LDWORK )
|
||||
*
|
||||
* C1 := C1 - W
|
||||
*
|
||||
DO 240 J = 1, K
|
||||
DO 230 I = 1, LASTC
|
||||
C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J )
|
||||
230 CONTINUE
|
||||
240 CONTINUE
|
||||
*
|
||||
END IF
|
||||
*
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of ZLARFB
|
||||
*
|
||||
END
|
||||
203
lib/linalg/zlarfg.f
Normal file
203
lib/linalg/zlarfg.f
Normal file
@ -0,0 +1,203 @@
|
||||
*> \brief \b ZLARFG generates an elementary reflector (Householder matrix).
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
*> \htmlonly
|
||||
*> Download ZLARFG + dependencies
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlarfg.f">
|
||||
*> [TGZ]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlarfg.f">
|
||||
*> [ZIP]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlarfg.f">
|
||||
*> [TXT]</a>
|
||||
*> \endhtmlonly
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE ZLARFG( N, ALPHA, X, INCX, TAU )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER INCX, N
|
||||
* COMPLEX*16 ALPHA, TAU
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* COMPLEX*16 X( * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> ZLARFG generates a complex elementary reflector H of order n, such
|
||||
*> that
|
||||
*>
|
||||
*> H**H * ( alpha ) = ( beta ), H**H * H = I.
|
||||
*> ( x ) ( 0 )
|
||||
*>
|
||||
*> where alpha and beta are scalars, with beta real, and x is an
|
||||
*> (n-1)-element complex vector. H is represented in the form
|
||||
*>
|
||||
*> H = I - tau * ( 1 ) * ( 1 v**H ) ,
|
||||
*> ( v )
|
||||
*>
|
||||
*> where tau is a complex scalar and v is a complex (n-1)-element
|
||||
*> vector. Note that H is not hermitian.
|
||||
*>
|
||||
*> If the elements of x are all zero and alpha is real, then tau = 0
|
||||
*> and H is taken to be the unit matrix.
|
||||
*>
|
||||
*> Otherwise 1 <= real(tau) <= 2 and abs(tau-1) <= 1 .
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> The order of the elementary reflector.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] ALPHA
|
||||
*> \verbatim
|
||||
*> ALPHA is COMPLEX*16
|
||||
*> On entry, the value alpha.
|
||||
*> On exit, it is overwritten with the value beta.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] X
|
||||
*> \verbatim
|
||||
*> X is COMPLEX*16 array, dimension
|
||||
*> (1+(N-2)*abs(INCX))
|
||||
*> On entry, the vector x.
|
||||
*> On exit, it is overwritten with the vector v.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] INCX
|
||||
*> \verbatim
|
||||
*> INCX is INTEGER
|
||||
*> The increment between elements of X. INCX > 0.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] TAU
|
||||
*> \verbatim
|
||||
*> TAU is COMPLEX*16
|
||||
*> The value tau.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date September 2012
|
||||
*
|
||||
*> \ingroup complex16OTHERauxiliary
|
||||
*
|
||||
* =====================================================================
|
||||
SUBROUTINE ZLARFG( N, ALPHA, X, INCX, TAU )
|
||||
*
|
||||
* -- LAPACK auxiliary routine (version 3.4.2) --
|
||||
* -- 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 ..
|
||||
INTEGER INCX, N
|
||||
COMPLEX*16 ALPHA, TAU
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
COMPLEX*16 X( * )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
DOUBLE PRECISION ONE, ZERO
|
||||
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
INTEGER J, KNT
|
||||
DOUBLE PRECISION ALPHI, ALPHR, BETA, RSAFMN, SAFMIN, XNORM
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
DOUBLE PRECISION DLAMCH, DLAPY3, DZNRM2
|
||||
COMPLEX*16 ZLADIV
|
||||
EXTERNAL DLAMCH, DLAPY3, DZNRM2, ZLADIV
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC ABS, DBLE, DCMPLX, DIMAG, SIGN
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL ZDSCAL, ZSCAL
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
IF( N.LE.0 ) THEN
|
||||
TAU = ZERO
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
XNORM = DZNRM2( N-1, X, INCX )
|
||||
ALPHR = DBLE( ALPHA )
|
||||
ALPHI = DIMAG( ALPHA )
|
||||
*
|
||||
IF( XNORM.EQ.ZERO .AND. ALPHI.EQ.ZERO ) THEN
|
||||
*
|
||||
* H = I
|
||||
*
|
||||
TAU = ZERO
|
||||
ELSE
|
||||
*
|
||||
* general case
|
||||
*
|
||||
BETA = -SIGN( DLAPY3( ALPHR, ALPHI, XNORM ), ALPHR )
|
||||
SAFMIN = DLAMCH( 'S' ) / DLAMCH( 'E' )
|
||||
RSAFMN = ONE / SAFMIN
|
||||
*
|
||||
KNT = 0
|
||||
IF( ABS( BETA ).LT.SAFMIN ) THEN
|
||||
*
|
||||
* XNORM, BETA may be inaccurate; scale X and recompute them
|
||||
*
|
||||
10 CONTINUE
|
||||
KNT = KNT + 1
|
||||
CALL ZDSCAL( N-1, RSAFMN, X, INCX )
|
||||
BETA = BETA*RSAFMN
|
||||
ALPHI = ALPHI*RSAFMN
|
||||
ALPHR = ALPHR*RSAFMN
|
||||
IF( ABS( BETA ).LT.SAFMIN )
|
||||
$ GO TO 10
|
||||
*
|
||||
* New BETA is at most 1, at least SAFMIN
|
||||
*
|
||||
XNORM = DZNRM2( N-1, X, INCX )
|
||||
ALPHA = DCMPLX( ALPHR, ALPHI )
|
||||
BETA = -SIGN( DLAPY3( ALPHR, ALPHI, XNORM ), ALPHR )
|
||||
END IF
|
||||
TAU = DCMPLX( ( BETA-ALPHR ) / BETA, -ALPHI / BETA )
|
||||
ALPHA = ZLADIV( DCMPLX( ONE ), ALPHA-BETA )
|
||||
CALL ZSCAL( N-1, ALPHA, X, INCX )
|
||||
*
|
||||
* If ALPHA is subnormal, it may lose relative accuracy
|
||||
*
|
||||
DO 20 J = 1, KNT
|
||||
BETA = BETA*SAFMIN
|
||||
20 CONTINUE
|
||||
ALPHA = BETA
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of ZLARFG
|
||||
*
|
||||
END
|
||||
327
lib/linalg/zlarft.f
Normal file
327
lib/linalg/zlarft.f
Normal file
@ -0,0 +1,327 @@
|
||||
*> \brief \b ZLARFT forms the triangular factor T of a block reflector H = I - vtvH
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
*> \htmlonly
|
||||
*> Download ZLARFT + dependencies
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlarft.f">
|
||||
*> [TGZ]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlarft.f">
|
||||
*> [ZIP]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlarft.f">
|
||||
*> [TXT]</a>
|
||||
*> \endhtmlonly
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE ZLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* CHARACTER DIRECT, STOREV
|
||||
* INTEGER K, LDT, LDV, N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* COMPLEX*16 T( LDT, * ), TAU( * ), V( LDV, * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> ZLARFT forms the triangular factor T of a complex block reflector H
|
||||
*> of order n, which is defined as a product of k elementary reflectors.
|
||||
*>
|
||||
*> If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular;
|
||||
*>
|
||||
*> If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular.
|
||||
*>
|
||||
*> If STOREV = 'C', the vector which defines the elementary reflector
|
||||
*> H(i) is stored in the i-th column of the array V, and
|
||||
*>
|
||||
*> H = I - V * T * V**H
|
||||
*>
|
||||
*> If STOREV = 'R', the vector which defines the elementary reflector
|
||||
*> H(i) is stored in the i-th row of the array V, and
|
||||
*>
|
||||
*> H = I - V**H * T * V
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] DIRECT
|
||||
*> \verbatim
|
||||
*> DIRECT is CHARACTER*1
|
||||
*> Specifies the order in which the elementary reflectors are
|
||||
*> multiplied to form the block reflector:
|
||||
*> = 'F': H = H(1) H(2) . . . H(k) (Forward)
|
||||
*> = 'B': H = H(k) . . . H(2) H(1) (Backward)
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] STOREV
|
||||
*> \verbatim
|
||||
*> STOREV is CHARACTER*1
|
||||
*> Specifies how the vectors which define the elementary
|
||||
*> reflectors are stored (see also Further Details):
|
||||
*> = 'C': columnwise
|
||||
*> = 'R': rowwise
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> The order of the block reflector H. N >= 0.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] K
|
||||
*> \verbatim
|
||||
*> K is INTEGER
|
||||
*> The order of the triangular factor T (= the number of
|
||||
*> elementary reflectors). K >= 1.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] V
|
||||
*> \verbatim
|
||||
*> V is COMPLEX*16 array, dimension
|
||||
*> (LDV,K) if STOREV = 'C'
|
||||
*> (LDV,N) if STOREV = 'R'
|
||||
*> The matrix V. See further details.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDV
|
||||
*> \verbatim
|
||||
*> LDV is INTEGER
|
||||
*> The leading dimension of the array V.
|
||||
*> If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] TAU
|
||||
*> \verbatim
|
||||
*> TAU is COMPLEX*16 array, dimension (K)
|
||||
*> TAU(i) must contain the scalar factor of the elementary
|
||||
*> reflector H(i).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] T
|
||||
*> \verbatim
|
||||
*> T is COMPLEX*16 array, dimension (LDT,K)
|
||||
*> The k by k triangular factor T of the block reflector.
|
||||
*> If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is
|
||||
*> lower triangular. The rest of the array is not used.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDT
|
||||
*> \verbatim
|
||||
*> LDT is INTEGER
|
||||
*> The leading dimension of the array T. LDT >= K.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date September 2012
|
||||
*
|
||||
*> \ingroup complex16OTHERauxiliary
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> The shape of the matrix V and the storage of the vectors which define
|
||||
*> the H(i) is best illustrated by the following example with n = 5 and
|
||||
*> k = 3. The elements equal to 1 are not stored.
|
||||
*>
|
||||
*> DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R':
|
||||
*>
|
||||
*> V = ( 1 ) V = ( 1 v1 v1 v1 v1 )
|
||||
*> ( v1 1 ) ( 1 v2 v2 v2 )
|
||||
*> ( v1 v2 1 ) ( 1 v3 v3 )
|
||||
*> ( v1 v2 v3 )
|
||||
*> ( v1 v2 v3 )
|
||||
*>
|
||||
*> DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R':
|
||||
*>
|
||||
*> V = ( v1 v2 v3 ) V = ( v1 v1 1 )
|
||||
*> ( v1 v2 v3 ) ( v2 v2 v2 1 )
|
||||
*> ( 1 v2 v3 ) ( v3 v3 v3 v3 1 )
|
||||
*> ( 1 v3 )
|
||||
*> ( 1 )
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
SUBROUTINE ZLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT )
|
||||
*
|
||||
* -- LAPACK auxiliary routine (version 3.4.2) --
|
||||
* -- 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 ..
|
||||
CHARACTER DIRECT, STOREV
|
||||
INTEGER K, LDT, LDV, N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
COMPLEX*16 T( LDT, * ), TAU( * ), V( LDV, * )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
COMPLEX*16 ONE, ZERO
|
||||
PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ),
|
||||
$ ZERO = ( 0.0D+0, 0.0D+0 ) )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
INTEGER I, J, PREVLASTV, LASTV
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL ZGEMV, ZLACGV, ZTRMV
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
EXTERNAL LSAME
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* Quick return if possible
|
||||
*
|
||||
IF( N.EQ.0 )
|
||||
$ RETURN
|
||||
*
|
||||
IF( LSAME( DIRECT, 'F' ) ) THEN
|
||||
PREVLASTV = N
|
||||
DO I = 1, K
|
||||
PREVLASTV = MAX( PREVLASTV, I )
|
||||
IF( TAU( I ).EQ.ZERO ) THEN
|
||||
*
|
||||
* H(i) = I
|
||||
*
|
||||
DO J = 1, I
|
||||
T( J, I ) = ZERO
|
||||
END DO
|
||||
ELSE
|
||||
*
|
||||
* general case
|
||||
*
|
||||
IF( LSAME( STOREV, 'C' ) ) THEN
|
||||
* Skip any trailing zeros.
|
||||
DO LASTV = N, I+1, -1
|
||||
IF( V( LASTV, I ).NE.ZERO ) EXIT
|
||||
END DO
|
||||
DO J = 1, I-1
|
||||
T( J, I ) = -TAU( I ) * CONJG( V( I , J ) )
|
||||
END DO
|
||||
J = MIN( LASTV, PREVLASTV )
|
||||
*
|
||||
* T(1:i-1,i) := - tau(i) * V(i:j,1:i-1)**H * V(i:j,i)
|
||||
*
|
||||
CALL ZGEMV( 'Conjugate transpose', J-I, I-1,
|
||||
$ -TAU( I ), V( I+1, 1 ), LDV,
|
||||
$ V( I+1, I ), 1, ONE, T( 1, I ), 1 )
|
||||
ELSE
|
||||
* Skip any trailing zeros.
|
||||
DO LASTV = N, I+1, -1
|
||||
IF( V( I, LASTV ).NE.ZERO ) EXIT
|
||||
END DO
|
||||
DO J = 1, I-1
|
||||
T( J, I ) = -TAU( I ) * V( J , I )
|
||||
END DO
|
||||
J = MIN( LASTV, PREVLASTV )
|
||||
*
|
||||
* T(1:i-1,i) := - tau(i) * V(1:i-1,i:j) * V(i,i:j)**H
|
||||
*
|
||||
CALL ZGEMM( 'N', 'C', I-1, 1, J-I, -TAU( I ),
|
||||
$ V( 1, I+1 ), LDV, V( I, I+1 ), LDV,
|
||||
$ ONE, T( 1, I ), LDT )
|
||||
END IF
|
||||
*
|
||||
* T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i)
|
||||
*
|
||||
CALL ZTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, T,
|
||||
$ LDT, T( 1, I ), 1 )
|
||||
T( I, I ) = TAU( I )
|
||||
IF( I.GT.1 ) THEN
|
||||
PREVLASTV = MAX( PREVLASTV, LASTV )
|
||||
ELSE
|
||||
PREVLASTV = LASTV
|
||||
END IF
|
||||
END IF
|
||||
END DO
|
||||
ELSE
|
||||
PREVLASTV = 1
|
||||
DO I = K, 1, -1
|
||||
IF( TAU( I ).EQ.ZERO ) THEN
|
||||
*
|
||||
* H(i) = I
|
||||
*
|
||||
DO J = I, K
|
||||
T( J, I ) = ZERO
|
||||
END DO
|
||||
ELSE
|
||||
*
|
||||
* general case
|
||||
*
|
||||
IF( I.LT.K ) THEN
|
||||
IF( LSAME( STOREV, 'C' ) ) THEN
|
||||
* Skip any leading zeros.
|
||||
DO LASTV = 1, I-1
|
||||
IF( V( LASTV, I ).NE.ZERO ) EXIT
|
||||
END DO
|
||||
DO J = I+1, K
|
||||
T( J, I ) = -TAU( I ) * CONJG( V( N-K+I , J ) )
|
||||
END DO
|
||||
J = MAX( LASTV, PREVLASTV )
|
||||
*
|
||||
* T(i+1:k,i) = -tau(i) * V(j:n-k+i,i+1:k)**H * V(j:n-k+i,i)
|
||||
*
|
||||
CALL ZGEMV( 'Conjugate transpose', N-K+I-J, K-I,
|
||||
$ -TAU( I ), V( J, I+1 ), LDV, V( J, I ),
|
||||
$ 1, ONE, T( I+1, I ), 1 )
|
||||
ELSE
|
||||
* Skip any leading zeros.
|
||||
DO LASTV = 1, I-1
|
||||
IF( V( I, LASTV ).NE.ZERO ) EXIT
|
||||
END DO
|
||||
DO J = I+1, K
|
||||
T( J, I ) = -TAU( I ) * V( J, N-K+I )
|
||||
END DO
|
||||
J = MAX( LASTV, PREVLASTV )
|
||||
*
|
||||
* T(i+1:k,i) = -tau(i) * V(i+1:k,j:n-k+i) * V(i,j:n-k+i)**H
|
||||
*
|
||||
CALL ZGEMM( 'N', 'C', K-I, 1, N-K+I-J, -TAU( I ),
|
||||
$ V( I+1, J ), LDV, V( I, J ), LDV,
|
||||
$ ONE, T( I+1, I ), LDT )
|
||||
END IF
|
||||
*
|
||||
* T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i)
|
||||
*
|
||||
CALL ZTRMV( 'Lower', 'No transpose', 'Non-unit', K-I,
|
||||
$ T( I+1, I+1 ), LDT, T( I+1, I ), 1 )
|
||||
IF( I.GT.1 ) THEN
|
||||
PREVLASTV = MIN( PREVLASTV, LASTV )
|
||||
ELSE
|
||||
PREVLASTV = LASTV
|
||||
END IF
|
||||
END IF
|
||||
T( I, I ) = TAU( I )
|
||||
END IF
|
||||
END DO
|
||||
END IF
|
||||
RETURN
|
||||
*
|
||||
* End of ZLARFT
|
||||
*
|
||||
END
|
||||
364
lib/linalg/zlascl.f
Normal file
364
lib/linalg/zlascl.f
Normal file
@ -0,0 +1,364 @@
|
||||
*> \brief \b ZLASCL multiplies a general rectangular matrix by a real scalar defined as cto/cfrom.
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
*> \htmlonly
|
||||
*> Download ZLASCL + dependencies
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlascl.f">
|
||||
*> [TGZ]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlascl.f">
|
||||
*> [ZIP]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlascl.f">
|
||||
*> [TXT]</a>
|
||||
*> \endhtmlonly
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE ZLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* CHARACTER TYPE
|
||||
* INTEGER INFO, KL, KU, LDA, M, N
|
||||
* DOUBLE PRECISION CFROM, CTO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* COMPLEX*16 A( LDA, * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> ZLASCL multiplies the M by N complex matrix A by the real scalar
|
||||
*> CTO/CFROM. This is done without over/underflow as long as the final
|
||||
*> result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that
|
||||
*> A may be full, upper triangular, lower triangular, upper Hessenberg,
|
||||
*> or banded.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] TYPE
|
||||
*> \verbatim
|
||||
*> TYPE is CHARACTER*1
|
||||
*> TYPE indices the storage type of the input matrix.
|
||||
*> = 'G': A is a full matrix.
|
||||
*> = 'L': A is a lower triangular matrix.
|
||||
*> = 'U': A is an upper triangular matrix.
|
||||
*> = 'H': A is an upper Hessenberg matrix.
|
||||
*> = 'B': A is a symmetric band matrix with lower bandwidth KL
|
||||
*> and upper bandwidth KU and with the only the lower
|
||||
*> half stored.
|
||||
*> = 'Q': A is a symmetric band matrix with lower bandwidth KL
|
||||
*> and upper bandwidth KU and with the only the upper
|
||||
*> half stored.
|
||||
*> = 'Z': A is a band matrix with lower bandwidth KL and upper
|
||||
*> bandwidth KU. See ZGBTRF for storage details.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] KL
|
||||
*> \verbatim
|
||||
*> KL is INTEGER
|
||||
*> The lower bandwidth of A. Referenced only if TYPE = 'B',
|
||||
*> 'Q' or 'Z'.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] KU
|
||||
*> \verbatim
|
||||
*> KU is INTEGER
|
||||
*> The upper bandwidth of A. Referenced only if TYPE = 'B',
|
||||
*> 'Q' or 'Z'.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] CFROM
|
||||
*> \verbatim
|
||||
*> CFROM is DOUBLE PRECISION
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] CTO
|
||||
*> \verbatim
|
||||
*> CTO is DOUBLE PRECISION
|
||||
*>
|
||||
*> The matrix A is multiplied by CTO/CFROM. A(I,J) is computed
|
||||
*> without over/underflow if the final result CTO*A(I,J)/CFROM
|
||||
*> can be represented without over/underflow. CFROM must be
|
||||
*> nonzero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] M
|
||||
*> \verbatim
|
||||
*> M is INTEGER
|
||||
*> The number of rows of the matrix A. M >= 0.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> The number of columns of the matrix A. N >= 0.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] A
|
||||
*> \verbatim
|
||||
*> A is COMPLEX*16 array, dimension (LDA,N)
|
||||
*> The matrix to be multiplied by CTO/CFROM. See TYPE for the
|
||||
*> storage type.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> The leading dimension of the array A. LDA >= max(1,M).
|
||||
*> \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 September 2012
|
||||
*
|
||||
*> \ingroup complex16OTHERauxiliary
|
||||
*
|
||||
* =====================================================================
|
||||
SUBROUTINE ZLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO )
|
||||
*
|
||||
* -- LAPACK auxiliary routine (version 3.4.2) --
|
||||
* -- 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 ..
|
||||
CHARACTER TYPE
|
||||
INTEGER INFO, KL, KU, LDA, M, N
|
||||
DOUBLE PRECISION CFROM, CTO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
COMPLEX*16 A( LDA, * )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
DOUBLE PRECISION ZERO, ONE
|
||||
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
LOGICAL DONE
|
||||
INTEGER I, ITYPE, J, K1, K2, K3, K4
|
||||
DOUBLE PRECISION BIGNUM, CFROM1, CFROMC, CTO1, CTOC, MUL, SMLNUM
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME, DISNAN
|
||||
DOUBLE PRECISION DLAMCH
|
||||
EXTERNAL LSAME, DLAMCH, DISNAN
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC ABS, MAX, MIN
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* Test the input arguments
|
||||
*
|
||||
INFO = 0
|
||||
*
|
||||
IF( LSAME( TYPE, 'G' ) ) THEN
|
||||
ITYPE = 0
|
||||
ELSE IF( LSAME( TYPE, 'L' ) ) THEN
|
||||
ITYPE = 1
|
||||
ELSE IF( LSAME( TYPE, 'U' ) ) THEN
|
||||
ITYPE = 2
|
||||
ELSE IF( LSAME( TYPE, 'H' ) ) THEN
|
||||
ITYPE = 3
|
||||
ELSE IF( LSAME( TYPE, 'B' ) ) THEN
|
||||
ITYPE = 4
|
||||
ELSE IF( LSAME( TYPE, 'Q' ) ) THEN
|
||||
ITYPE = 5
|
||||
ELSE IF( LSAME( TYPE, 'Z' ) ) THEN
|
||||
ITYPE = 6
|
||||
ELSE
|
||||
ITYPE = -1
|
||||
END IF
|
||||
*
|
||||
IF( ITYPE.EQ.-1 ) THEN
|
||||
INFO = -1
|
||||
ELSE IF( CFROM.EQ.ZERO .OR. DISNAN(CFROM) ) THEN
|
||||
INFO = -4
|
||||
ELSE IF( DISNAN(CTO) ) THEN
|
||||
INFO = -5
|
||||
ELSE IF( M.LT.0 ) THEN
|
||||
INFO = -6
|
||||
ELSE IF( N.LT.0 .OR. ( ITYPE.EQ.4 .AND. N.NE.M ) .OR.
|
||||
$ ( ITYPE.EQ.5 .AND. N.NE.M ) ) THEN
|
||||
INFO = -7
|
||||
ELSE IF( ITYPE.LE.3 .AND. LDA.LT.MAX( 1, M ) ) THEN
|
||||
INFO = -9
|
||||
ELSE IF( ITYPE.GE.4 ) THEN
|
||||
IF( KL.LT.0 .OR. KL.GT.MAX( M-1, 0 ) ) THEN
|
||||
INFO = -2
|
||||
ELSE IF( KU.LT.0 .OR. KU.GT.MAX( N-1, 0 ) .OR.
|
||||
$ ( ( ITYPE.EQ.4 .OR. ITYPE.EQ.5 ) .AND. KL.NE.KU ) )
|
||||
$ THEN
|
||||
INFO = -3
|
||||
ELSE IF( ( ITYPE.EQ.4 .AND. LDA.LT.KL+1 ) .OR.
|
||||
$ ( ITYPE.EQ.5 .AND. LDA.LT.KU+1 ) .OR.
|
||||
$ ( ITYPE.EQ.6 .AND. LDA.LT.2*KL+KU+1 ) ) THEN
|
||||
INFO = -9
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
IF( INFO.NE.0 ) THEN
|
||||
CALL XERBLA( 'ZLASCL', -INFO )
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible
|
||||
*
|
||||
IF( N.EQ.0 .OR. M.EQ.0 )
|
||||
$ RETURN
|
||||
*
|
||||
* Get machine parameters
|
||||
*
|
||||
SMLNUM = DLAMCH( 'S' )
|
||||
BIGNUM = ONE / SMLNUM
|
||||
*
|
||||
CFROMC = CFROM
|
||||
CTOC = CTO
|
||||
*
|
||||
10 CONTINUE
|
||||
CFROM1 = CFROMC*SMLNUM
|
||||
IF( CFROM1.EQ.CFROMC ) THEN
|
||||
! CFROMC is an inf. Multiply by a correctly signed zero for
|
||||
! finite CTOC, or a NaN if CTOC is infinite.
|
||||
MUL = CTOC / CFROMC
|
||||
DONE = .TRUE.
|
||||
CTO1 = CTOC
|
||||
ELSE
|
||||
CTO1 = CTOC / BIGNUM
|
||||
IF( CTO1.EQ.CTOC ) THEN
|
||||
! CTOC is either 0 or an inf. In both cases, CTOC itself
|
||||
! serves as the correct multiplication factor.
|
||||
MUL = CTOC
|
||||
DONE = .TRUE.
|
||||
CFROMC = ONE
|
||||
ELSE IF( ABS( CFROM1 ).GT.ABS( CTOC ) .AND. CTOC.NE.ZERO ) THEN
|
||||
MUL = SMLNUM
|
||||
DONE = .FALSE.
|
||||
CFROMC = CFROM1
|
||||
ELSE IF( ABS( CTO1 ).GT.ABS( CFROMC ) ) THEN
|
||||
MUL = BIGNUM
|
||||
DONE = .FALSE.
|
||||
CTOC = CTO1
|
||||
ELSE
|
||||
MUL = CTOC / CFROMC
|
||||
DONE = .TRUE.
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
IF( ITYPE.EQ.0 ) THEN
|
||||
*
|
||||
* Full matrix
|
||||
*
|
||||
DO 30 J = 1, N
|
||||
DO 20 I = 1, M
|
||||
A( I, J ) = A( I, J )*MUL
|
||||
20 CONTINUE
|
||||
30 CONTINUE
|
||||
*
|
||||
ELSE IF( ITYPE.EQ.1 ) THEN
|
||||
*
|
||||
* Lower triangular matrix
|
||||
*
|
||||
DO 50 J = 1, N
|
||||
DO 40 I = J, M
|
||||
A( I, J ) = A( I, J )*MUL
|
||||
40 CONTINUE
|
||||
50 CONTINUE
|
||||
*
|
||||
ELSE IF( ITYPE.EQ.2 ) THEN
|
||||
*
|
||||
* Upper triangular matrix
|
||||
*
|
||||
DO 70 J = 1, N
|
||||
DO 60 I = 1, MIN( J, M )
|
||||
A( I, J ) = A( I, J )*MUL
|
||||
60 CONTINUE
|
||||
70 CONTINUE
|
||||
*
|
||||
ELSE IF( ITYPE.EQ.3 ) THEN
|
||||
*
|
||||
* Upper Hessenberg matrix
|
||||
*
|
||||
DO 90 J = 1, N
|
||||
DO 80 I = 1, MIN( J+1, M )
|
||||
A( I, J ) = A( I, J )*MUL
|
||||
80 CONTINUE
|
||||
90 CONTINUE
|
||||
*
|
||||
ELSE IF( ITYPE.EQ.4 ) THEN
|
||||
*
|
||||
* Lower half of a symmetric band matrix
|
||||
*
|
||||
K3 = KL + 1
|
||||
K4 = N + 1
|
||||
DO 110 J = 1, N
|
||||
DO 100 I = 1, MIN( K3, K4-J )
|
||||
A( I, J ) = A( I, J )*MUL
|
||||
100 CONTINUE
|
||||
110 CONTINUE
|
||||
*
|
||||
ELSE IF( ITYPE.EQ.5 ) THEN
|
||||
*
|
||||
* Upper half of a symmetric band matrix
|
||||
*
|
||||
K1 = KU + 2
|
||||
K3 = KU + 1
|
||||
DO 130 J = 1, N
|
||||
DO 120 I = MAX( K1-J, 1 ), K3
|
||||
A( I, J ) = A( I, J )*MUL
|
||||
120 CONTINUE
|
||||
130 CONTINUE
|
||||
*
|
||||
ELSE IF( ITYPE.EQ.6 ) THEN
|
||||
*
|
||||
* Band matrix
|
||||
*
|
||||
K1 = KL + KU + 2
|
||||
K2 = KL + 1
|
||||
K3 = 2*KL + KU + 1
|
||||
K4 = KL + KU + 1 + M
|
||||
DO 150 J = 1, N
|
||||
DO 140 I = MAX( K1-J, K2 ), MIN( K3, K4-J )
|
||||
A( I, J ) = A( I, J )*MUL
|
||||
140 CONTINUE
|
||||
150 CONTINUE
|
||||
*
|
||||
END IF
|
||||
*
|
||||
IF( .NOT.DONE )
|
||||
$ GO TO 10
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of ZLASCL
|
||||
*
|
||||
END
|
||||
184
lib/linalg/zlaset.f
Normal file
184
lib/linalg/zlaset.f
Normal file
@ -0,0 +1,184 @@
|
||||
*> \brief \b ZLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values.
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
*> \htmlonly
|
||||
*> Download ZLASET + dependencies
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlaset.f">
|
||||
*> [TGZ]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlaset.f">
|
||||
*> [ZIP]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlaset.f">
|
||||
*> [TXT]</a>
|
||||
*> \endhtmlonly
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE ZLASET( UPLO, M, N, ALPHA, BETA, A, LDA )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* CHARACTER UPLO
|
||||
* INTEGER LDA, M, N
|
||||
* COMPLEX*16 ALPHA, BETA
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* COMPLEX*16 A( LDA, * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> ZLASET initializes a 2-D array A to BETA on the diagonal and
|
||||
*> ALPHA on the offdiagonals.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] UPLO
|
||||
*> \verbatim
|
||||
*> UPLO is CHARACTER*1
|
||||
*> Specifies the part of the matrix A to be set.
|
||||
*> = 'U': Upper triangular part is set. The lower triangle
|
||||
*> is unchanged.
|
||||
*> = 'L': Lower triangular part is set. The upper triangle
|
||||
*> is unchanged.
|
||||
*> Otherwise: All of the matrix A is set.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] M
|
||||
*> \verbatim
|
||||
*> M is INTEGER
|
||||
*> On entry, M specifies the number of rows of A.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> On entry, N specifies the number of columns of A.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] ALPHA
|
||||
*> \verbatim
|
||||
*> ALPHA is COMPLEX*16
|
||||
*> All the offdiagonal array elements are set to ALPHA.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] BETA
|
||||
*> \verbatim
|
||||
*> BETA is COMPLEX*16
|
||||
*> All the diagonal array elements are set to BETA.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] A
|
||||
*> \verbatim
|
||||
*> A is COMPLEX*16 array, dimension (LDA,N)
|
||||
*> On entry, the m by n matrix A.
|
||||
*> On exit, A(i,j) = ALPHA, 1 <= i <= m, 1 <= j <= n, i.ne.j;
|
||||
*> A(i,i) = BETA , 1 <= i <= min(m,n)
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> The leading dimension of the array A. LDA >= max(1,M).
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date September 2012
|
||||
*
|
||||
*> \ingroup complex16OTHERauxiliary
|
||||
*
|
||||
* =====================================================================
|
||||
SUBROUTINE ZLASET( UPLO, M, N, ALPHA, BETA, A, LDA )
|
||||
*
|
||||
* -- LAPACK auxiliary routine (version 3.4.2) --
|
||||
* -- 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 ..
|
||||
CHARACTER UPLO
|
||||
INTEGER LDA, M, N
|
||||
COMPLEX*16 ALPHA, BETA
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
COMPLEX*16 A( LDA, * )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Local Scalars ..
|
||||
INTEGER I, J
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
EXTERNAL LSAME
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC MIN
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
IF( LSAME( UPLO, 'U' ) ) THEN
|
||||
*
|
||||
* Set the diagonal to BETA and the strictly upper triangular
|
||||
* part of the array to ALPHA.
|
||||
*
|
||||
DO 20 J = 2, N
|
||||
DO 10 I = 1, MIN( J-1, M )
|
||||
A( I, J ) = ALPHA
|
||||
10 CONTINUE
|
||||
20 CONTINUE
|
||||
DO 30 I = 1, MIN( N, M )
|
||||
A( I, I ) = BETA
|
||||
30 CONTINUE
|
||||
*
|
||||
ELSE IF( LSAME( UPLO, 'L' ) ) THEN
|
||||
*
|
||||
* Set the diagonal to BETA and the strictly lower triangular
|
||||
* part of the array to ALPHA.
|
||||
*
|
||||
DO 50 J = 1, MIN( M, N )
|
||||
DO 40 I = J + 1, M
|
||||
A( I, J ) = ALPHA
|
||||
40 CONTINUE
|
||||
50 CONTINUE
|
||||
DO 60 I = 1, MIN( N, M )
|
||||
A( I, I ) = BETA
|
||||
60 CONTINUE
|
||||
*
|
||||
ELSE
|
||||
*
|
||||
* Set the array to BETA on the diagonal and ALPHA on the
|
||||
* offdiagonal.
|
||||
*
|
||||
DO 80 J = 1, N
|
||||
DO 70 I = 1, M
|
||||
A( I, J ) = ALPHA
|
||||
70 CONTINUE
|
||||
80 CONTINUE
|
||||
DO 90 I = 1, MIN( M, N )
|
||||
A( I, I ) = BETA
|
||||
90 CONTINUE
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of ZLASET
|
||||
*
|
||||
END
|
||||
439
lib/linalg/zlasr.f
Normal file
439
lib/linalg/zlasr.f
Normal file
@ -0,0 +1,439 @@
|
||||
*> \brief \b ZLASR applies a sequence of plane rotations to a general rectangular matrix.
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
*> \htmlonly
|
||||
*> Download ZLASR + dependencies
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlasr.f">
|
||||
*> [TGZ]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlasr.f">
|
||||
*> [ZIP]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlasr.f">
|
||||
*> [TXT]</a>
|
||||
*> \endhtmlonly
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE ZLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* CHARACTER DIRECT, PIVOT, SIDE
|
||||
* INTEGER LDA, M, N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* DOUBLE PRECISION C( * ), S( * )
|
||||
* COMPLEX*16 A( LDA, * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> ZLASR applies a sequence of real plane rotations to a complex matrix
|
||||
*> A, from either the left or the right.
|
||||
*>
|
||||
*> When SIDE = 'L', the transformation takes the form
|
||||
*>
|
||||
*> A := P*A
|
||||
*>
|
||||
*> and when SIDE = 'R', the transformation takes the form
|
||||
*>
|
||||
*> A := A*P**T
|
||||
*>
|
||||
*> where P is an orthogonal matrix consisting of a sequence of z plane
|
||||
*> rotations, with z = M when SIDE = 'L' and z = N when SIDE = 'R',
|
||||
*> and P**T is the transpose of P.
|
||||
*>
|
||||
*> When DIRECT = 'F' (Forward sequence), then
|
||||
*>
|
||||
*> P = P(z-1) * ... * P(2) * P(1)
|
||||
*>
|
||||
*> and when DIRECT = 'B' (Backward sequence), then
|
||||
*>
|
||||
*> P = P(1) * P(2) * ... * P(z-1)
|
||||
*>
|
||||
*> where P(k) is a plane rotation matrix defined by the 2-by-2 rotation
|
||||
*>
|
||||
*> R(k) = ( c(k) s(k) )
|
||||
*> = ( -s(k) c(k) ).
|
||||
*>
|
||||
*> When PIVOT = 'V' (Variable pivot), the rotation is performed
|
||||
*> for the plane (k,k+1), i.e., P(k) has the form
|
||||
*>
|
||||
*> P(k) = ( 1 )
|
||||
*> ( ... )
|
||||
*> ( 1 )
|
||||
*> ( c(k) s(k) )
|
||||
*> ( -s(k) c(k) )
|
||||
*> ( 1 )
|
||||
*> ( ... )
|
||||
*> ( 1 )
|
||||
*>
|
||||
*> where R(k) appears as a rank-2 modification to the identity matrix in
|
||||
*> rows and columns k and k+1.
|
||||
*>
|
||||
*> When PIVOT = 'T' (Top pivot), the rotation is performed for the
|
||||
*> plane (1,k+1), so P(k) has the form
|
||||
*>
|
||||
*> P(k) = ( c(k) s(k) )
|
||||
*> ( 1 )
|
||||
*> ( ... )
|
||||
*> ( 1 )
|
||||
*> ( -s(k) c(k) )
|
||||
*> ( 1 )
|
||||
*> ( ... )
|
||||
*> ( 1 )
|
||||
*>
|
||||
*> where R(k) appears in rows and columns 1 and k+1.
|
||||
*>
|
||||
*> Similarly, when PIVOT = 'B' (Bottom pivot), the rotation is
|
||||
*> performed for the plane (k,z), giving P(k) the form
|
||||
*>
|
||||
*> P(k) = ( 1 )
|
||||
*> ( ... )
|
||||
*> ( 1 )
|
||||
*> ( c(k) s(k) )
|
||||
*> ( 1 )
|
||||
*> ( ... )
|
||||
*> ( 1 )
|
||||
*> ( -s(k) c(k) )
|
||||
*>
|
||||
*> where R(k) appears in rows and columns k and z. The rotations are
|
||||
*> performed without ever forming P(k) explicitly.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] SIDE
|
||||
*> \verbatim
|
||||
*> SIDE is CHARACTER*1
|
||||
*> Specifies whether the plane rotation matrix P is applied to
|
||||
*> A on the left or the right.
|
||||
*> = 'L': Left, compute A := P*A
|
||||
*> = 'R': Right, compute A:= A*P**T
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] PIVOT
|
||||
*> \verbatim
|
||||
*> PIVOT is CHARACTER*1
|
||||
*> Specifies the plane for which P(k) is a plane rotation
|
||||
*> matrix.
|
||||
*> = 'V': Variable pivot, the plane (k,k+1)
|
||||
*> = 'T': Top pivot, the plane (1,k+1)
|
||||
*> = 'B': Bottom pivot, the plane (k,z)
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] DIRECT
|
||||
*> \verbatim
|
||||
*> DIRECT is CHARACTER*1
|
||||
*> Specifies whether P is a forward or backward sequence of
|
||||
*> plane rotations.
|
||||
*> = 'F': Forward, P = P(z-1)*...*P(2)*P(1)
|
||||
*> = 'B': Backward, P = P(1)*P(2)*...*P(z-1)
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] M
|
||||
*> \verbatim
|
||||
*> M is INTEGER
|
||||
*> The number of rows of the matrix A. If m <= 1, an immediate
|
||||
*> return is effected.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> The number of columns of the matrix A. If n <= 1, an
|
||||
*> immediate return is effected.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] C
|
||||
*> \verbatim
|
||||
*> C is DOUBLE PRECISION array, dimension
|
||||
*> (M-1) if SIDE = 'L'
|
||||
*> (N-1) if SIDE = 'R'
|
||||
*> The cosines c(k) of the plane rotations.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] S
|
||||
*> \verbatim
|
||||
*> S is DOUBLE PRECISION array, dimension
|
||||
*> (M-1) if SIDE = 'L'
|
||||
*> (N-1) if SIDE = 'R'
|
||||
*> The sines s(k) of the plane rotations. The 2-by-2 plane
|
||||
*> rotation part of the matrix P(k), R(k), has the form
|
||||
*> R(k) = ( c(k) s(k) )
|
||||
*> ( -s(k) c(k) ).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] A
|
||||
*> \verbatim
|
||||
*> A is COMPLEX*16 array, dimension (LDA,N)
|
||||
*> The M-by-N matrix A. On exit, A is overwritten by P*A if
|
||||
*> SIDE = 'R' or by A*P**T if SIDE = 'L'.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> The leading dimension of the array A. LDA >= max(1,M).
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date September 2012
|
||||
*
|
||||
*> \ingroup complex16OTHERauxiliary
|
||||
*
|
||||
* =====================================================================
|
||||
SUBROUTINE ZLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA )
|
||||
*
|
||||
* -- LAPACK auxiliary routine (version 3.4.2) --
|
||||
* -- 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 ..
|
||||
CHARACTER DIRECT, PIVOT, SIDE
|
||||
INTEGER LDA, M, N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION C( * ), S( * )
|
||||
COMPLEX*16 A( LDA, * )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
DOUBLE PRECISION ONE, ZERO
|
||||
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
INTEGER I, INFO, J
|
||||
DOUBLE PRECISION CTEMP, STEMP
|
||||
COMPLEX*16 TEMP
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC MAX
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
EXTERNAL LSAME
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* Test the input parameters
|
||||
*
|
||||
INFO = 0
|
||||
IF( .NOT.( LSAME( SIDE, 'L' ) .OR. LSAME( SIDE, 'R' ) ) ) THEN
|
||||
INFO = 1
|
||||
ELSE IF( .NOT.( LSAME( PIVOT, 'V' ) .OR. LSAME( PIVOT,
|
||||
$ 'T' ) .OR. LSAME( PIVOT, 'B' ) ) ) THEN
|
||||
INFO = 2
|
||||
ELSE IF( .NOT.( LSAME( DIRECT, 'F' ) .OR. LSAME( DIRECT, 'B' ) ) )
|
||||
$ THEN
|
||||
INFO = 3
|
||||
ELSE IF( M.LT.0 ) THEN
|
||||
INFO = 4
|
||||
ELSE IF( N.LT.0 ) THEN
|
||||
INFO = 5
|
||||
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
|
||||
INFO = 9
|
||||
END IF
|
||||
IF( INFO.NE.0 ) THEN
|
||||
CALL XERBLA( 'ZLASR ', INFO )
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible
|
||||
*
|
||||
IF( ( M.EQ.0 ) .OR. ( N.EQ.0 ) )
|
||||
$ RETURN
|
||||
IF( LSAME( SIDE, 'L' ) ) THEN
|
||||
*
|
||||
* Form P * A
|
||||
*
|
||||
IF( LSAME( PIVOT, 'V' ) ) THEN
|
||||
IF( LSAME( DIRECT, 'F' ) ) THEN
|
||||
DO 20 J = 1, M - 1
|
||||
CTEMP = C( J )
|
||||
STEMP = S( J )
|
||||
IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
|
||||
DO 10 I = 1, N
|
||||
TEMP = A( J+1, I )
|
||||
A( J+1, I ) = CTEMP*TEMP - STEMP*A( J, I )
|
||||
A( J, I ) = STEMP*TEMP + CTEMP*A( J, I )
|
||||
10 CONTINUE
|
||||
END IF
|
||||
20 CONTINUE
|
||||
ELSE IF( LSAME( DIRECT, 'B' ) ) THEN
|
||||
DO 40 J = M - 1, 1, -1
|
||||
CTEMP = C( J )
|
||||
STEMP = S( J )
|
||||
IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
|
||||
DO 30 I = 1, N
|
||||
TEMP = A( J+1, I )
|
||||
A( J+1, I ) = CTEMP*TEMP - STEMP*A( J, I )
|
||||
A( J, I ) = STEMP*TEMP + CTEMP*A( J, I )
|
||||
30 CONTINUE
|
||||
END IF
|
||||
40 CONTINUE
|
||||
END IF
|
||||
ELSE IF( LSAME( PIVOT, 'T' ) ) THEN
|
||||
IF( LSAME( DIRECT, 'F' ) ) THEN
|
||||
DO 60 J = 2, M
|
||||
CTEMP = C( J-1 )
|
||||
STEMP = S( J-1 )
|
||||
IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
|
||||
DO 50 I = 1, N
|
||||
TEMP = A( J, I )
|
||||
A( J, I ) = CTEMP*TEMP - STEMP*A( 1, I )
|
||||
A( 1, I ) = STEMP*TEMP + CTEMP*A( 1, I )
|
||||
50 CONTINUE
|
||||
END IF
|
||||
60 CONTINUE
|
||||
ELSE IF( LSAME( DIRECT, 'B' ) ) THEN
|
||||
DO 80 J = M, 2, -1
|
||||
CTEMP = C( J-1 )
|
||||
STEMP = S( J-1 )
|
||||
IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
|
||||
DO 70 I = 1, N
|
||||
TEMP = A( J, I )
|
||||
A( J, I ) = CTEMP*TEMP - STEMP*A( 1, I )
|
||||
A( 1, I ) = STEMP*TEMP + CTEMP*A( 1, I )
|
||||
70 CONTINUE
|
||||
END IF
|
||||
80 CONTINUE
|
||||
END IF
|
||||
ELSE IF( LSAME( PIVOT, 'B' ) ) THEN
|
||||
IF( LSAME( DIRECT, 'F' ) ) THEN
|
||||
DO 100 J = 1, M - 1
|
||||
CTEMP = C( J )
|
||||
STEMP = S( J )
|
||||
IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
|
||||
DO 90 I = 1, N
|
||||
TEMP = A( J, I )
|
||||
A( J, I ) = STEMP*A( M, I ) + CTEMP*TEMP
|
||||
A( M, I ) = CTEMP*A( M, I ) - STEMP*TEMP
|
||||
90 CONTINUE
|
||||
END IF
|
||||
100 CONTINUE
|
||||
ELSE IF( LSAME( DIRECT, 'B' ) ) THEN
|
||||
DO 120 J = M - 1, 1, -1
|
||||
CTEMP = C( J )
|
||||
STEMP = S( J )
|
||||
IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
|
||||
DO 110 I = 1, N
|
||||
TEMP = A( J, I )
|
||||
A( J, I ) = STEMP*A( M, I ) + CTEMP*TEMP
|
||||
A( M, I ) = CTEMP*A( M, I ) - STEMP*TEMP
|
||||
110 CONTINUE
|
||||
END IF
|
||||
120 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
ELSE IF( LSAME( SIDE, 'R' ) ) THEN
|
||||
*
|
||||
* Form A * P**T
|
||||
*
|
||||
IF( LSAME( PIVOT, 'V' ) ) THEN
|
||||
IF( LSAME( DIRECT, 'F' ) ) THEN
|
||||
DO 140 J = 1, N - 1
|
||||
CTEMP = C( J )
|
||||
STEMP = S( J )
|
||||
IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
|
||||
DO 130 I = 1, M
|
||||
TEMP = A( I, J+1 )
|
||||
A( I, J+1 ) = CTEMP*TEMP - STEMP*A( I, J )
|
||||
A( I, J ) = STEMP*TEMP + CTEMP*A( I, J )
|
||||
130 CONTINUE
|
||||
END IF
|
||||
140 CONTINUE
|
||||
ELSE IF( LSAME( DIRECT, 'B' ) ) THEN
|
||||
DO 160 J = N - 1, 1, -1
|
||||
CTEMP = C( J )
|
||||
STEMP = S( J )
|
||||
IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
|
||||
DO 150 I = 1, M
|
||||
TEMP = A( I, J+1 )
|
||||
A( I, J+1 ) = CTEMP*TEMP - STEMP*A( I, J )
|
||||
A( I, J ) = STEMP*TEMP + CTEMP*A( I, J )
|
||||
150 CONTINUE
|
||||
END IF
|
||||
160 CONTINUE
|
||||
END IF
|
||||
ELSE IF( LSAME( PIVOT, 'T' ) ) THEN
|
||||
IF( LSAME( DIRECT, 'F' ) ) THEN
|
||||
DO 180 J = 2, N
|
||||
CTEMP = C( J-1 )
|
||||
STEMP = S( J-1 )
|
||||
IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
|
||||
DO 170 I = 1, M
|
||||
TEMP = A( I, J )
|
||||
A( I, J ) = CTEMP*TEMP - STEMP*A( I, 1 )
|
||||
A( I, 1 ) = STEMP*TEMP + CTEMP*A( I, 1 )
|
||||
170 CONTINUE
|
||||
END IF
|
||||
180 CONTINUE
|
||||
ELSE IF( LSAME( DIRECT, 'B' ) ) THEN
|
||||
DO 200 J = N, 2, -1
|
||||
CTEMP = C( J-1 )
|
||||
STEMP = S( J-1 )
|
||||
IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
|
||||
DO 190 I = 1, M
|
||||
TEMP = A( I, J )
|
||||
A( I, J ) = CTEMP*TEMP - STEMP*A( I, 1 )
|
||||
A( I, 1 ) = STEMP*TEMP + CTEMP*A( I, 1 )
|
||||
190 CONTINUE
|
||||
END IF
|
||||
200 CONTINUE
|
||||
END IF
|
||||
ELSE IF( LSAME( PIVOT, 'B' ) ) THEN
|
||||
IF( LSAME( DIRECT, 'F' ) ) THEN
|
||||
DO 220 J = 1, N - 1
|
||||
CTEMP = C( J )
|
||||
STEMP = S( J )
|
||||
IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
|
||||
DO 210 I = 1, M
|
||||
TEMP = A( I, J )
|
||||
A( I, J ) = STEMP*A( I, N ) + CTEMP*TEMP
|
||||
A( I, N ) = CTEMP*A( I, N ) - STEMP*TEMP
|
||||
210 CONTINUE
|
||||
END IF
|
||||
220 CONTINUE
|
||||
ELSE IF( LSAME( DIRECT, 'B' ) ) THEN
|
||||
DO 240 J = N - 1, 1, -1
|
||||
CTEMP = C( J )
|
||||
STEMP = S( J )
|
||||
IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
|
||||
DO 230 I = 1, M
|
||||
TEMP = A( I, J )
|
||||
A( I, J ) = STEMP*A( I, N ) + CTEMP*TEMP
|
||||
A( I, N ) = CTEMP*A( I, N ) - STEMP*TEMP
|
||||
230 CONTINUE
|
||||
END IF
|
||||
240 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of ZLASR
|
||||
*
|
||||
END
|
||||
168
lib/linalg/zlassq.f
Normal file
168
lib/linalg/zlassq.f
Normal file
@ -0,0 +1,168 @@
|
||||
*> \brief \b ZLASSQ updates a sum of squares represented in scaled form.
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
*> \htmlonly
|
||||
*> Download ZLASSQ + dependencies
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlassq.f">
|
||||
*> [TGZ]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlassq.f">
|
||||
*> [ZIP]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlassq.f">
|
||||
*> [TXT]</a>
|
||||
*> \endhtmlonly
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE ZLASSQ( N, X, INCX, SCALE, SUMSQ )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER INCX, N
|
||||
* DOUBLE PRECISION SCALE, SUMSQ
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* COMPLEX*16 X( * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> ZLASSQ returns the values scl and ssq such that
|
||||
*>
|
||||
*> ( scl**2 )*ssq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq,
|
||||
*>
|
||||
*> where x( i ) = abs( X( 1 + ( i - 1 )*INCX ) ). The value of sumsq is
|
||||
*> assumed to be at least unity and the value of ssq will then satisfy
|
||||
*>
|
||||
*> 1.0 .le. ssq .le. ( sumsq + 2*n ).
|
||||
*>
|
||||
*> scale is assumed to be non-negative and scl returns the value
|
||||
*>
|
||||
*> scl = max( scale, abs( real( x( i ) ) ), abs( aimag( x( i ) ) ) ),
|
||||
*> i
|
||||
*>
|
||||
*> scale and sumsq must be supplied in SCALE and SUMSQ respectively.
|
||||
*> SCALE and SUMSQ are overwritten by scl and ssq respectively.
|
||||
*>
|
||||
*> The routine makes only one pass through the vector X.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> The number of elements to be used from the vector X.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] X
|
||||
*> \verbatim
|
||||
*> X is COMPLEX*16 array, dimension (N)
|
||||
*> The vector x as described above.
|
||||
*> x( i ) = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] INCX
|
||||
*> \verbatim
|
||||
*> INCX is INTEGER
|
||||
*> The increment between successive values of the vector X.
|
||||
*> INCX > 0.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] SCALE
|
||||
*> \verbatim
|
||||
*> SCALE is DOUBLE PRECISION
|
||||
*> On entry, the value scale in the equation above.
|
||||
*> On exit, SCALE is overwritten with the value scl .
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] SUMSQ
|
||||
*> \verbatim
|
||||
*> SUMSQ is DOUBLE PRECISION
|
||||
*> On entry, the value sumsq in the equation above.
|
||||
*> On exit, SUMSQ is overwritten with the value ssq .
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date September 2012
|
||||
*
|
||||
*> \ingroup complex16OTHERauxiliary
|
||||
*
|
||||
* =====================================================================
|
||||
SUBROUTINE ZLASSQ( N, X, INCX, SCALE, SUMSQ )
|
||||
*
|
||||
* -- LAPACK auxiliary routine (version 3.4.2) --
|
||||
* -- 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 ..
|
||||
INTEGER INCX, N
|
||||
DOUBLE PRECISION SCALE, SUMSQ
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
COMPLEX*16 X( * )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
DOUBLE PRECISION ZERO
|
||||
PARAMETER ( ZERO = 0.0D+0 )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
INTEGER IX
|
||||
DOUBLE PRECISION TEMP1
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
LOGICAL DISNAN
|
||||
EXTERNAL DISNAN
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC ABS, DBLE, DIMAG
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
IF( N.GT.0 ) THEN
|
||||
DO 10 IX = 1, 1 + ( N-1 )*INCX, INCX
|
||||
TEMP1 = ABS( DBLE( X( IX ) ) )
|
||||
IF( TEMP1.GT.ZERO.OR.DISNAN( TEMP1 ) ) THEN
|
||||
IF( SCALE.LT.TEMP1 ) THEN
|
||||
SUMSQ = 1 + SUMSQ*( SCALE / TEMP1 )**2
|
||||
SCALE = TEMP1
|
||||
ELSE
|
||||
SUMSQ = SUMSQ + ( TEMP1 / SCALE )**2
|
||||
END IF
|
||||
END IF
|
||||
TEMP1 = ABS( DIMAG( X( IX ) ) )
|
||||
IF( TEMP1.GT.ZERO.OR.DISNAN( TEMP1 ) ) THEN
|
||||
IF( SCALE.LT.TEMP1 ) THEN
|
||||
SUMSQ = 1 + SUMSQ*( SCALE / TEMP1 )**2
|
||||
SCALE = TEMP1
|
||||
ELSE
|
||||
SUMSQ = SUMSQ + ( TEMP1 / SCALE )**2
|
||||
END IF
|
||||
END IF
|
||||
10 CONTINUE
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of ZLASSQ
|
||||
*
|
||||
END
|
||||
358
lib/linalg/zlatrd.f
Normal file
358
lib/linalg/zlatrd.f
Normal file
@ -0,0 +1,358 @@
|
||||
*> \brief \b ZLATRD reduces the first nb rows and columns of a symmetric/Hermitian matrix A to real tridiagonal form by an unitary similarity transformation.
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
*> \htmlonly
|
||||
*> Download ZLATRD + dependencies
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlatrd.f">
|
||||
*> [TGZ]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlatrd.f">
|
||||
*> [ZIP]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlatrd.f">
|
||||
*> [TXT]</a>
|
||||
*> \endhtmlonly
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE ZLATRD( UPLO, N, NB, A, LDA, E, TAU, W, LDW )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* CHARACTER UPLO
|
||||
* INTEGER LDA, LDW, N, NB
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* DOUBLE PRECISION E( * )
|
||||
* COMPLEX*16 A( LDA, * ), TAU( * ), W( LDW, * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> ZLATRD reduces NB rows and columns of a complex Hermitian matrix A to
|
||||
*> Hermitian tridiagonal form by a unitary similarity
|
||||
*> transformation Q**H * A * Q, and returns the matrices V and W which are
|
||||
*> needed to apply the transformation to the unreduced part of A.
|
||||
*>
|
||||
*> If UPLO = 'U', ZLATRD reduces the last NB rows and columns of a
|
||||
*> matrix, of which the upper triangle is supplied;
|
||||
*> if UPLO = 'L', ZLATRD reduces the first NB rows and columns of a
|
||||
*> matrix, of which the lower triangle is supplied.
|
||||
*>
|
||||
*> This is an auxiliary routine called by ZHETRD.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] UPLO
|
||||
*> \verbatim
|
||||
*> UPLO is CHARACTER*1
|
||||
*> Specifies whether the upper or lower triangular part of the
|
||||
*> Hermitian matrix A is stored:
|
||||
*> = 'U': Upper triangular
|
||||
*> = 'L': Lower triangular
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> The order of the matrix A.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] NB
|
||||
*> \verbatim
|
||||
*> NB is INTEGER
|
||||
*> The number of rows and columns to be reduced.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] A
|
||||
*> \verbatim
|
||||
*> A is COMPLEX*16 array, dimension (LDA,N)
|
||||
*> On entry, the Hermitian matrix A. If UPLO = 'U', the leading
|
||||
*> n-by-n upper triangular part of A contains the upper
|
||||
*> triangular part of the matrix A, and the strictly lower
|
||||
*> triangular part of A is not referenced. If UPLO = 'L', the
|
||||
*> leading n-by-n lower triangular part of A contains the lower
|
||||
*> triangular part of the matrix A, and the strictly upper
|
||||
*> triangular part of A is not referenced.
|
||||
*> On exit:
|
||||
*> if UPLO = 'U', the last NB columns have been reduced to
|
||||
*> tridiagonal form, with the diagonal elements overwriting
|
||||
*> the diagonal elements of A; the elements above the diagonal
|
||||
*> with the array TAU, represent the unitary matrix Q as a
|
||||
*> product of elementary reflectors;
|
||||
*> if UPLO = 'L', the first NB columns have been reduced to
|
||||
*> tridiagonal form, with the diagonal elements overwriting
|
||||
*> the diagonal elements of A; the elements below the diagonal
|
||||
*> with the array TAU, represent the unitary matrix Q as a
|
||||
*> product of elementary reflectors.
|
||||
*> See Further Details.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> The leading dimension of the array A. LDA >= max(1,N).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] E
|
||||
*> \verbatim
|
||||
*> E is DOUBLE PRECISION array, dimension (N-1)
|
||||
*> If UPLO = 'U', E(n-nb:n-1) contains the superdiagonal
|
||||
*> elements of the last NB columns of the reduced matrix;
|
||||
*> if UPLO = 'L', E(1:nb) contains the subdiagonal elements of
|
||||
*> the first NB columns of the reduced matrix.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] TAU
|
||||
*> \verbatim
|
||||
*> TAU is COMPLEX*16 array, dimension (N-1)
|
||||
*> The scalar factors of the elementary reflectors, stored in
|
||||
*> TAU(n-nb:n-1) if UPLO = 'U', and in TAU(1:nb) if UPLO = 'L'.
|
||||
*> See Further Details.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] W
|
||||
*> \verbatim
|
||||
*> W is COMPLEX*16 array, dimension (LDW,NB)
|
||||
*> The n-by-nb matrix W required to update the unreduced part
|
||||
*> of A.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDW
|
||||
*> \verbatim
|
||||
*> LDW is INTEGER
|
||||
*> The leading dimension of the array W. LDW >= max(1,N).
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date September 2012
|
||||
*
|
||||
*> \ingroup complex16OTHERauxiliary
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> If UPLO = 'U', the matrix Q is represented as a product of elementary
|
||||
*> reflectors
|
||||
*>
|
||||
*> Q = H(n) H(n-1) . . . H(n-nb+1).
|
||||
*>
|
||||
*> Each H(i) has the form
|
||||
*>
|
||||
*> H(i) = I - tau * v * v**H
|
||||
*>
|
||||
*> where tau is a complex scalar, and v is a complex vector with
|
||||
*> v(i:n) = 0 and v(i-1) = 1; v(1:i-1) is stored on exit in A(1:i-1,i),
|
||||
*> and tau in TAU(i-1).
|
||||
*>
|
||||
*> If UPLO = 'L', the matrix Q is represented as a product of elementary
|
||||
*> reflectors
|
||||
*>
|
||||
*> Q = H(1) H(2) . . . H(nb).
|
||||
*>
|
||||
*> Each H(i) has the form
|
||||
*>
|
||||
*> H(i) = I - tau * v * v**H
|
||||
*>
|
||||
*> where tau is a complex scalar, and v is a complex vector with
|
||||
*> v(1:i) = 0 and v(i+1) = 1; v(i+1:n) is stored on exit in A(i+1:n,i),
|
||||
*> and tau in TAU(i).
|
||||
*>
|
||||
*> The elements of the vectors v together form the n-by-nb matrix V
|
||||
*> which is needed, with W, to apply the transformation to the unreduced
|
||||
*> part of the matrix, using a Hermitian rank-2k update of the form:
|
||||
*> A := A - V*W**H - W*V**H.
|
||||
*>
|
||||
*> The contents of A on exit are illustrated by the following examples
|
||||
*> with n = 5 and nb = 2:
|
||||
*>
|
||||
*> if UPLO = 'U': if UPLO = 'L':
|
||||
*>
|
||||
*> ( a a a v4 v5 ) ( d )
|
||||
*> ( a a v4 v5 ) ( 1 d )
|
||||
*> ( a 1 v5 ) ( v1 1 a )
|
||||
*> ( d 1 ) ( v1 v2 a a )
|
||||
*> ( d ) ( v1 v2 a a a )
|
||||
*>
|
||||
*> where d denotes a diagonal element of the reduced matrix, a denotes
|
||||
*> an element of the original matrix that is unchanged, and vi denotes
|
||||
*> an element of the vector defining H(i).
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
SUBROUTINE ZLATRD( UPLO, N, NB, A, LDA, E, TAU, W, LDW )
|
||||
*
|
||||
* -- LAPACK auxiliary routine (version 3.4.2) --
|
||||
* -- 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 ..
|
||||
CHARACTER UPLO
|
||||
INTEGER LDA, LDW, N, NB
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION E( * )
|
||||
COMPLEX*16 A( LDA, * ), TAU( * ), W( LDW, * )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
COMPLEX*16 ZERO, ONE, HALF
|
||||
PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ),
|
||||
$ ONE = ( 1.0D+0, 0.0D+0 ),
|
||||
$ HALF = ( 0.5D+0, 0.0D+0 ) )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
INTEGER I, IW
|
||||
COMPLEX*16 ALPHA
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL ZAXPY, ZGEMV, ZHEMV, ZLACGV, ZLARFG, ZSCAL
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
COMPLEX*16 ZDOTC
|
||||
EXTERNAL LSAME, ZDOTC
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC DBLE, MIN
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* Quick return if possible
|
||||
*
|
||||
IF( N.LE.0 )
|
||||
$ RETURN
|
||||
*
|
||||
IF( LSAME( UPLO, 'U' ) ) THEN
|
||||
*
|
||||
* Reduce last NB columns of upper triangle
|
||||
*
|
||||
DO 10 I = N, N - NB + 1, -1
|
||||
IW = I - N + NB
|
||||
IF( I.LT.N ) THEN
|
||||
*
|
||||
* Update A(1:i,i)
|
||||
*
|
||||
A( I, I ) = DBLE( A( I, I ) )
|
||||
CALL ZLACGV( N-I, W( I, IW+1 ), LDW )
|
||||
CALL ZGEMV( 'No transpose', I, N-I, -ONE, A( 1, I+1 ),
|
||||
$ LDA, W( I, IW+1 ), LDW, ONE, A( 1, I ), 1 )
|
||||
CALL ZLACGV( N-I, W( I, IW+1 ), LDW )
|
||||
CALL ZLACGV( N-I, A( I, I+1 ), LDA )
|
||||
CALL ZGEMV( 'No transpose', I, N-I, -ONE, W( 1, IW+1 ),
|
||||
$ LDW, A( I, I+1 ), LDA, ONE, A( 1, I ), 1 )
|
||||
CALL ZLACGV( N-I, A( I, I+1 ), LDA )
|
||||
A( I, I ) = DBLE( A( I, I ) )
|
||||
END IF
|
||||
IF( I.GT.1 ) THEN
|
||||
*
|
||||
* Generate elementary reflector H(i) to annihilate
|
||||
* A(1:i-2,i)
|
||||
*
|
||||
ALPHA = A( I-1, I )
|
||||
CALL ZLARFG( I-1, ALPHA, A( 1, I ), 1, TAU( I-1 ) )
|
||||
E( I-1 ) = ALPHA
|
||||
A( I-1, I ) = ONE
|
||||
*
|
||||
* Compute W(1:i-1,i)
|
||||
*
|
||||
CALL ZHEMV( 'Upper', I-1, ONE, A, LDA, A( 1, I ), 1,
|
||||
$ ZERO, W( 1, IW ), 1 )
|
||||
IF( I.LT.N ) THEN
|
||||
CALL ZGEMV( 'Conjugate transpose', I-1, N-I, ONE,
|
||||
$ W( 1, IW+1 ), LDW, A( 1, I ), 1, ZERO,
|
||||
$ W( I+1, IW ), 1 )
|
||||
CALL ZGEMV( 'No transpose', I-1, N-I, -ONE,
|
||||
$ A( 1, I+1 ), LDA, W( I+1, IW ), 1, ONE,
|
||||
$ W( 1, IW ), 1 )
|
||||
CALL ZGEMV( 'Conjugate transpose', I-1, N-I, ONE,
|
||||
$ A( 1, I+1 ), LDA, A( 1, I ), 1, ZERO,
|
||||
$ W( I+1, IW ), 1 )
|
||||
CALL ZGEMV( 'No transpose', I-1, N-I, -ONE,
|
||||
$ W( 1, IW+1 ), LDW, W( I+1, IW ), 1, ONE,
|
||||
$ W( 1, IW ), 1 )
|
||||
END IF
|
||||
CALL ZSCAL( I-1, TAU( I-1 ), W( 1, IW ), 1 )
|
||||
ALPHA = -HALF*TAU( I-1 )*ZDOTC( I-1, W( 1, IW ), 1,
|
||||
$ A( 1, I ), 1 )
|
||||
CALL ZAXPY( I-1, ALPHA, A( 1, I ), 1, W( 1, IW ), 1 )
|
||||
END IF
|
||||
*
|
||||
10 CONTINUE
|
||||
ELSE
|
||||
*
|
||||
* Reduce first NB columns of lower triangle
|
||||
*
|
||||
DO 20 I = 1, NB
|
||||
*
|
||||
* Update A(i:n,i)
|
||||
*
|
||||
A( I, I ) = DBLE( A( I, I ) )
|
||||
CALL ZLACGV( I-1, W( I, 1 ), LDW )
|
||||
CALL ZGEMV( 'No transpose', N-I+1, I-1, -ONE, A( I, 1 ),
|
||||
$ LDA, W( I, 1 ), LDW, ONE, A( I, I ), 1 )
|
||||
CALL ZLACGV( I-1, W( I, 1 ), LDW )
|
||||
CALL ZLACGV( I-1, A( I, 1 ), LDA )
|
||||
CALL ZGEMV( 'No transpose', N-I+1, I-1, -ONE, W( I, 1 ),
|
||||
$ LDW, A( I, 1 ), LDA, ONE, A( I, I ), 1 )
|
||||
CALL ZLACGV( I-1, A( I, 1 ), LDA )
|
||||
A( I, I ) = DBLE( A( I, I ) )
|
||||
IF( I.LT.N ) THEN
|
||||
*
|
||||
* Generate elementary reflector H(i) to annihilate
|
||||
* A(i+2:n,i)
|
||||
*
|
||||
ALPHA = A( I+1, I )
|
||||
CALL ZLARFG( N-I, ALPHA, A( MIN( I+2, N ), I ), 1,
|
||||
$ TAU( I ) )
|
||||
E( I ) = ALPHA
|
||||
A( I+1, I ) = ONE
|
||||
*
|
||||
* Compute W(i+1:n,i)
|
||||
*
|
||||
CALL ZHEMV( 'Lower', N-I, ONE, A( I+1, I+1 ), LDA,
|
||||
$ A( I+1, I ), 1, ZERO, W( I+1, I ), 1 )
|
||||
CALL ZGEMV( 'Conjugate transpose', N-I, I-1, ONE,
|
||||
$ W( I+1, 1 ), LDW, A( I+1, I ), 1, ZERO,
|
||||
$ W( 1, I ), 1 )
|
||||
CALL ZGEMV( 'No transpose', N-I, I-1, -ONE, A( I+1, 1 ),
|
||||
$ LDA, W( 1, I ), 1, ONE, W( I+1, I ), 1 )
|
||||
CALL ZGEMV( 'Conjugate transpose', N-I, I-1, ONE,
|
||||
$ A( I+1, 1 ), LDA, A( I+1, I ), 1, ZERO,
|
||||
$ W( 1, I ), 1 )
|
||||
CALL ZGEMV( 'No transpose', N-I, I-1, -ONE, W( I+1, 1 ),
|
||||
$ LDW, W( 1, I ), 1, ONE, W( I+1, I ), 1 )
|
||||
CALL ZSCAL( N-I, TAU( I ), W( I+1, I ), 1 )
|
||||
ALPHA = -HALF*TAU( I )*ZDOTC( N-I, W( I+1, I ), 1,
|
||||
$ A( I+1, I ), 1 )
|
||||
CALL ZAXPY( N-I, ALPHA, A( I+1, I ), 1, W( I+1, I ), 1 )
|
||||
END IF
|
||||
*
|
||||
20 CONTINUE
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of ZLATRD
|
||||
*
|
||||
END
|
||||
576
lib/linalg/zsteqr.f
Normal file
576
lib/linalg/zsteqr.f
Normal file
@ -0,0 +1,576 @@
|
||||
*> \brief \b ZSTEQR
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
*> \htmlonly
|
||||
*> Download ZSTEQR + dependencies
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zsteqr.f">
|
||||
*> [TGZ]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zsteqr.f">
|
||||
*> [ZIP]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zsteqr.f">
|
||||
*> [TXT]</a>
|
||||
*> \endhtmlonly
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE ZSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* CHARACTER COMPZ
|
||||
* INTEGER INFO, LDZ, N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* DOUBLE PRECISION D( * ), E( * ), WORK( * )
|
||||
* COMPLEX*16 Z( LDZ, * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> ZSTEQR computes all eigenvalues and, optionally, eigenvectors of a
|
||||
*> symmetric tridiagonal matrix using the implicit QL or QR method.
|
||||
*> The eigenvectors of a full or band complex Hermitian matrix can also
|
||||
*> be found if ZHETRD or ZHPTRD or ZHBTRD has been used to reduce this
|
||||
*> matrix to tridiagonal form.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] COMPZ
|
||||
*> \verbatim
|
||||
*> COMPZ is CHARACTER*1
|
||||
*> = 'N': Compute eigenvalues only.
|
||||
*> = 'V': Compute eigenvalues and eigenvectors of the original
|
||||
*> Hermitian matrix. On entry, Z must contain the
|
||||
*> unitary matrix used to reduce the original matrix
|
||||
*> to tridiagonal form.
|
||||
*> = 'I': Compute eigenvalues and eigenvectors of the
|
||||
*> tridiagonal matrix. Z is initialized to the identity
|
||||
*> matrix.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> The order of the matrix. N >= 0.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] D
|
||||
*> \verbatim
|
||||
*> D is DOUBLE PRECISION array, dimension (N)
|
||||
*> On entry, the diagonal elements of the tridiagonal matrix.
|
||||
*> On exit, if INFO = 0, the eigenvalues in ascending order.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] E
|
||||
*> \verbatim
|
||||
*> E is DOUBLE PRECISION array, dimension (N-1)
|
||||
*> On entry, the (n-1) subdiagonal elements of the tridiagonal
|
||||
*> matrix.
|
||||
*> On exit, E has been destroyed.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] Z
|
||||
*> \verbatim
|
||||
*> Z is COMPLEX*16 array, dimension (LDZ, N)
|
||||
*> On entry, if COMPZ = 'V', then Z contains the unitary
|
||||
*> matrix used in the reduction to tridiagonal form.
|
||||
*> On exit, if INFO = 0, then if COMPZ = 'V', Z contains the
|
||||
*> orthonormal eigenvectors of the original Hermitian matrix,
|
||||
*> and if COMPZ = 'I', Z contains the orthonormal eigenvectors
|
||||
*> of the symmetric tridiagonal matrix.
|
||||
*> If COMPZ = 'N', then Z is not referenced.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDZ
|
||||
*> \verbatim
|
||||
*> LDZ is INTEGER
|
||||
*> The leading dimension of the array Z. LDZ >= 1, and if
|
||||
*> eigenvectors are desired, then LDZ >= max(1,N).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] WORK
|
||||
*> \verbatim
|
||||
*> WORK is DOUBLE PRECISION array, dimension (max(1,2*N-2))
|
||||
*> If COMPZ = 'N', then WORK is not referenced.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] INFO
|
||||
*> \verbatim
|
||||
*> INFO is INTEGER
|
||||
*> = 0: successful exit
|
||||
*> < 0: if INFO = -i, the i-th argument had an illegal value
|
||||
*> > 0: the algorithm has failed to find all the eigenvalues in
|
||||
*> a total of 30*N iterations; if INFO = i, then i
|
||||
*> elements of E have not converged to zero; on exit, D
|
||||
*> and E contain the elements of a symmetric tridiagonal
|
||||
*> matrix which is unitarily similar to the original
|
||||
*> matrix.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup complex16OTHERcomputational
|
||||
*
|
||||
* =====================================================================
|
||||
SUBROUTINE ZSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO )
|
||||
*
|
||||
* -- LAPACK computational routine (version 3.4.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
CHARACTER COMPZ
|
||||
INTEGER INFO, LDZ, N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION D( * ), E( * ), WORK( * )
|
||||
COMPLEX*16 Z( LDZ, * )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
DOUBLE PRECISION ZERO, ONE, TWO, THREE
|
||||
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0,
|
||||
$ THREE = 3.0D0 )
|
||||
COMPLEX*16 CZERO, CONE
|
||||
PARAMETER ( CZERO = ( 0.0D0, 0.0D0 ),
|
||||
$ CONE = ( 1.0D0, 0.0D0 ) )
|
||||
INTEGER MAXIT
|
||||
PARAMETER ( MAXIT = 30 )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
INTEGER I, ICOMPZ, II, ISCALE, J, JTOT, K, L, L1, LEND,
|
||||
$ LENDM1, LENDP1, LENDSV, LM1, LSV, M, MM, MM1,
|
||||
$ NM1, NMAXIT
|
||||
DOUBLE PRECISION ANORM, B, C, EPS, EPS2, F, G, P, R, RT1, RT2,
|
||||
$ S, SAFMAX, SAFMIN, SSFMAX, SSFMIN, TST
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
DOUBLE PRECISION DLAMCH, DLANST, DLAPY2
|
||||
EXTERNAL LSAME, DLAMCH, DLANST, DLAPY2
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL DLAE2, DLAEV2, DLARTG, DLASCL, DLASRT, XERBLA,
|
||||
$ ZLASET, ZLASR, ZSWAP
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC ABS, MAX, SIGN, SQRT
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* Test the input parameters.
|
||||
*
|
||||
INFO = 0
|
||||
*
|
||||
IF( LSAME( COMPZ, 'N' ) ) THEN
|
||||
ICOMPZ = 0
|
||||
ELSE IF( LSAME( COMPZ, 'V' ) ) THEN
|
||||
ICOMPZ = 1
|
||||
ELSE IF( LSAME( COMPZ, 'I' ) ) THEN
|
||||
ICOMPZ = 2
|
||||
ELSE
|
||||
ICOMPZ = -1
|
||||
END IF
|
||||
IF( ICOMPZ.LT.0 ) THEN
|
||||
INFO = -1
|
||||
ELSE IF( N.LT.0 ) THEN
|
||||
INFO = -2
|
||||
ELSE IF( ( LDZ.LT.1 ) .OR. ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX( 1,
|
||||
$ N ) ) ) THEN
|
||||
INFO = -6
|
||||
END IF
|
||||
IF( INFO.NE.0 ) THEN
|
||||
CALL XERBLA( 'ZSTEQR', -INFO )
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible
|
||||
*
|
||||
IF( N.EQ.0 )
|
||||
$ RETURN
|
||||
*
|
||||
IF( N.EQ.1 ) THEN
|
||||
IF( ICOMPZ.EQ.2 )
|
||||
$ Z( 1, 1 ) = CONE
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Determine the unit roundoff and over/underflow thresholds.
|
||||
*
|
||||
EPS = DLAMCH( 'E' )
|
||||
EPS2 = EPS**2
|
||||
SAFMIN = DLAMCH( 'S' )
|
||||
SAFMAX = ONE / SAFMIN
|
||||
SSFMAX = SQRT( SAFMAX ) / THREE
|
||||
SSFMIN = SQRT( SAFMIN ) / EPS2
|
||||
*
|
||||
* Compute the eigenvalues and eigenvectors of the tridiagonal
|
||||
* matrix.
|
||||
*
|
||||
IF( ICOMPZ.EQ.2 )
|
||||
$ CALL ZLASET( 'Full', N, N, CZERO, CONE, Z, LDZ )
|
||||
*
|
||||
NMAXIT = N*MAXIT
|
||||
JTOT = 0
|
||||
*
|
||||
* Determine where the matrix splits and choose QL or QR iteration
|
||||
* for each block, according to whether top or bottom diagonal
|
||||
* element is smaller.
|
||||
*
|
||||
L1 = 1
|
||||
NM1 = N - 1
|
||||
*
|
||||
10 CONTINUE
|
||||
IF( L1.GT.N )
|
||||
$ GO TO 160
|
||||
IF( L1.GT.1 )
|
||||
$ E( L1-1 ) = ZERO
|
||||
IF( L1.LE.NM1 ) THEN
|
||||
DO 20 M = L1, NM1
|
||||
TST = ABS( E( M ) )
|
||||
IF( TST.EQ.ZERO )
|
||||
$ GO TO 30
|
||||
IF( TST.LE.( SQRT( ABS( D( M ) ) )*SQRT( ABS( D( M+
|
||||
$ 1 ) ) ) )*EPS ) THEN
|
||||
E( M ) = ZERO
|
||||
GO TO 30
|
||||
END IF
|
||||
20 CONTINUE
|
||||
END IF
|
||||
M = N
|
||||
*
|
||||
30 CONTINUE
|
||||
L = L1
|
||||
LSV = L
|
||||
LEND = M
|
||||
LENDSV = LEND
|
||||
L1 = M + 1
|
||||
IF( LEND.EQ.L )
|
||||
$ GO TO 10
|
||||
*
|
||||
* Scale submatrix in rows and columns L to LEND
|
||||
*
|
||||
ANORM = DLANST( 'I', LEND-L+1, D( L ), E( L ) )
|
||||
ISCALE = 0
|
||||
IF( ANORM.EQ.ZERO )
|
||||
$ GO TO 10
|
||||
IF( ANORM.GT.SSFMAX ) THEN
|
||||
ISCALE = 1
|
||||
CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L+1, 1, D( L ), N,
|
||||
$ INFO )
|
||||
CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L, 1, E( L ), N,
|
||||
$ INFO )
|
||||
ELSE IF( ANORM.LT.SSFMIN ) THEN
|
||||
ISCALE = 2
|
||||
CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L+1, 1, D( L ), N,
|
||||
$ INFO )
|
||||
CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L, 1, E( L ), N,
|
||||
$ INFO )
|
||||
END IF
|
||||
*
|
||||
* Choose between QL and QR iteration
|
||||
*
|
||||
IF( ABS( D( LEND ) ).LT.ABS( D( L ) ) ) THEN
|
||||
LEND = LSV
|
||||
L = LENDSV
|
||||
END IF
|
||||
*
|
||||
IF( LEND.GT.L ) THEN
|
||||
*
|
||||
* QL Iteration
|
||||
*
|
||||
* Look for small subdiagonal element.
|
||||
*
|
||||
40 CONTINUE
|
||||
IF( L.NE.LEND ) THEN
|
||||
LENDM1 = LEND - 1
|
||||
DO 50 M = L, LENDM1
|
||||
TST = ABS( E( M ) )**2
|
||||
IF( TST.LE.( EPS2*ABS( D( M ) ) )*ABS( D( M+1 ) )+
|
||||
$ SAFMIN )GO TO 60
|
||||
50 CONTINUE
|
||||
END IF
|
||||
*
|
||||
M = LEND
|
||||
*
|
||||
60 CONTINUE
|
||||
IF( M.LT.LEND )
|
||||
$ E( M ) = ZERO
|
||||
P = D( L )
|
||||
IF( M.EQ.L )
|
||||
$ GO TO 80
|
||||
*
|
||||
* If remaining matrix is 2-by-2, use DLAE2 or SLAEV2
|
||||
* to compute its eigensystem.
|
||||
*
|
||||
IF( M.EQ.L+1 ) THEN
|
||||
IF( ICOMPZ.GT.0 ) THEN
|
||||
CALL DLAEV2( D( L ), E( L ), D( L+1 ), RT1, RT2, C, S )
|
||||
WORK( L ) = C
|
||||
WORK( N-1+L ) = S
|
||||
CALL ZLASR( 'R', 'V', 'B', N, 2, WORK( L ),
|
||||
$ WORK( N-1+L ), Z( 1, L ), LDZ )
|
||||
ELSE
|
||||
CALL DLAE2( D( L ), E( L ), D( L+1 ), RT1, RT2 )
|
||||
END IF
|
||||
D( L ) = RT1
|
||||
D( L+1 ) = RT2
|
||||
E( L ) = ZERO
|
||||
L = L + 2
|
||||
IF( L.LE.LEND )
|
||||
$ GO TO 40
|
||||
GO TO 140
|
||||
END IF
|
||||
*
|
||||
IF( JTOT.EQ.NMAXIT )
|
||||
$ GO TO 140
|
||||
JTOT = JTOT + 1
|
||||
*
|
||||
* Form shift.
|
||||
*
|
||||
G = ( D( L+1 )-P ) / ( TWO*E( L ) )
|
||||
R = DLAPY2( G, ONE )
|
||||
G = D( M ) - P + ( E( L ) / ( G+SIGN( R, G ) ) )
|
||||
*
|
||||
S = ONE
|
||||
C = ONE
|
||||
P = ZERO
|
||||
*
|
||||
* Inner loop
|
||||
*
|
||||
MM1 = M - 1
|
||||
DO 70 I = MM1, L, -1
|
||||
F = S*E( I )
|
||||
B = C*E( I )
|
||||
CALL DLARTG( G, F, C, S, R )
|
||||
IF( I.NE.M-1 )
|
||||
$ E( I+1 ) = R
|
||||
G = D( I+1 ) - P
|
||||
R = ( D( I )-G )*S + TWO*C*B
|
||||
P = S*R
|
||||
D( I+1 ) = G + P
|
||||
G = C*R - B
|
||||
*
|
||||
* If eigenvectors are desired, then save rotations.
|
||||
*
|
||||
IF( ICOMPZ.GT.0 ) THEN
|
||||
WORK( I ) = C
|
||||
WORK( N-1+I ) = -S
|
||||
END IF
|
||||
*
|
||||
70 CONTINUE
|
||||
*
|
||||
* If eigenvectors are desired, then apply saved rotations.
|
||||
*
|
||||
IF( ICOMPZ.GT.0 ) THEN
|
||||
MM = M - L + 1
|
||||
CALL ZLASR( 'R', 'V', 'B', N, MM, WORK( L ), WORK( N-1+L ),
|
||||
$ Z( 1, L ), LDZ )
|
||||
END IF
|
||||
*
|
||||
D( L ) = D( L ) - P
|
||||
E( L ) = G
|
||||
GO TO 40
|
||||
*
|
||||
* Eigenvalue found.
|
||||
*
|
||||
80 CONTINUE
|
||||
D( L ) = P
|
||||
*
|
||||
L = L + 1
|
||||
IF( L.LE.LEND )
|
||||
$ GO TO 40
|
||||
GO TO 140
|
||||
*
|
||||
ELSE
|
||||
*
|
||||
* QR Iteration
|
||||
*
|
||||
* Look for small superdiagonal element.
|
||||
*
|
||||
90 CONTINUE
|
||||
IF( L.NE.LEND ) THEN
|
||||
LENDP1 = LEND + 1
|
||||
DO 100 M = L, LENDP1, -1
|
||||
TST = ABS( E( M-1 ) )**2
|
||||
IF( TST.LE.( EPS2*ABS( D( M ) ) )*ABS( D( M-1 ) )+
|
||||
$ SAFMIN )GO TO 110
|
||||
100 CONTINUE
|
||||
END IF
|
||||
*
|
||||
M = LEND
|
||||
*
|
||||
110 CONTINUE
|
||||
IF( M.GT.LEND )
|
||||
$ E( M-1 ) = ZERO
|
||||
P = D( L )
|
||||
IF( M.EQ.L )
|
||||
$ GO TO 130
|
||||
*
|
||||
* If remaining matrix is 2-by-2, use DLAE2 or SLAEV2
|
||||
* to compute its eigensystem.
|
||||
*
|
||||
IF( M.EQ.L-1 ) THEN
|
||||
IF( ICOMPZ.GT.0 ) THEN
|
||||
CALL DLAEV2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2, C, S )
|
||||
WORK( M ) = C
|
||||
WORK( N-1+M ) = S
|
||||
CALL ZLASR( 'R', 'V', 'F', N, 2, WORK( M ),
|
||||
$ WORK( N-1+M ), Z( 1, L-1 ), LDZ )
|
||||
ELSE
|
||||
CALL DLAE2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2 )
|
||||
END IF
|
||||
D( L-1 ) = RT1
|
||||
D( L ) = RT2
|
||||
E( L-1 ) = ZERO
|
||||
L = L - 2
|
||||
IF( L.GE.LEND )
|
||||
$ GO TO 90
|
||||
GO TO 140
|
||||
END IF
|
||||
*
|
||||
IF( JTOT.EQ.NMAXIT )
|
||||
$ GO TO 140
|
||||
JTOT = JTOT + 1
|
||||
*
|
||||
* Form shift.
|
||||
*
|
||||
G = ( D( L-1 )-P ) / ( TWO*E( L-1 ) )
|
||||
R = DLAPY2( G, ONE )
|
||||
G = D( M ) - P + ( E( L-1 ) / ( G+SIGN( R, G ) ) )
|
||||
*
|
||||
S = ONE
|
||||
C = ONE
|
||||
P = ZERO
|
||||
*
|
||||
* Inner loop
|
||||
*
|
||||
LM1 = L - 1
|
||||
DO 120 I = M, LM1
|
||||
F = S*E( I )
|
||||
B = C*E( I )
|
||||
CALL DLARTG( G, F, C, S, R )
|
||||
IF( I.NE.M )
|
||||
$ E( I-1 ) = R
|
||||
G = D( I ) - P
|
||||
R = ( D( I+1 )-G )*S + TWO*C*B
|
||||
P = S*R
|
||||
D( I ) = G + P
|
||||
G = C*R - B
|
||||
*
|
||||
* If eigenvectors are desired, then save rotations.
|
||||
*
|
||||
IF( ICOMPZ.GT.0 ) THEN
|
||||
WORK( I ) = C
|
||||
WORK( N-1+I ) = S
|
||||
END IF
|
||||
*
|
||||
120 CONTINUE
|
||||
*
|
||||
* If eigenvectors are desired, then apply saved rotations.
|
||||
*
|
||||
IF( ICOMPZ.GT.0 ) THEN
|
||||
MM = L - M + 1
|
||||
CALL ZLASR( 'R', 'V', 'F', N, MM, WORK( M ), WORK( N-1+M ),
|
||||
$ Z( 1, M ), LDZ )
|
||||
END IF
|
||||
*
|
||||
D( L ) = D( L ) - P
|
||||
E( LM1 ) = G
|
||||
GO TO 90
|
||||
*
|
||||
* Eigenvalue found.
|
||||
*
|
||||
130 CONTINUE
|
||||
D( L ) = P
|
||||
*
|
||||
L = L - 1
|
||||
IF( L.GE.LEND )
|
||||
$ GO TO 90
|
||||
GO TO 140
|
||||
*
|
||||
END IF
|
||||
*
|
||||
* Undo scaling if necessary
|
||||
*
|
||||
140 CONTINUE
|
||||
IF( ISCALE.EQ.1 ) THEN
|
||||
CALL DLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV+1, 1,
|
||||
$ D( LSV ), N, INFO )
|
||||
CALL DLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV, 1, E( LSV ),
|
||||
$ N, INFO )
|
||||
ELSE IF( ISCALE.EQ.2 ) THEN
|
||||
CALL DLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV+1, 1,
|
||||
$ D( LSV ), N, INFO )
|
||||
CALL DLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV, 1, E( LSV ),
|
||||
$ N, INFO )
|
||||
END IF
|
||||
*
|
||||
* Check for no convergence to an eigenvalue after a total
|
||||
* of N*MAXIT iterations.
|
||||
*
|
||||
IF( JTOT.EQ.NMAXIT ) THEN
|
||||
DO 150 I = 1, N - 1
|
||||
IF( E( I ).NE.ZERO )
|
||||
$ INFO = INFO + 1
|
||||
150 CONTINUE
|
||||
RETURN
|
||||
END IF
|
||||
GO TO 10
|
||||
*
|
||||
* Order eigenvalues and eigenvectors.
|
||||
*
|
||||
160 CONTINUE
|
||||
IF( ICOMPZ.EQ.0 ) THEN
|
||||
*
|
||||
* Use Quick Sort
|
||||
*
|
||||
CALL DLASRT( 'I', N, D, INFO )
|
||||
*
|
||||
ELSE
|
||||
*
|
||||
* Use Selection Sort to minimize swaps of eigenvectors
|
||||
*
|
||||
DO 180 II = 2, N
|
||||
I = II - 1
|
||||
K = I
|
||||
P = D( I )
|
||||
DO 170 J = II, N
|
||||
IF( D( J ).LT.P ) THEN
|
||||
K = J
|
||||
P = D( J )
|
||||
END IF
|
||||
170 CONTINUE
|
||||
IF( K.NE.I ) THEN
|
||||
D( K ) = D( I )
|
||||
D( I ) = P
|
||||
CALL ZSWAP( N, Z( 1, I ), 1, Z( 1, K ), 1 )
|
||||
END IF
|
||||
180 CONTINUE
|
||||
END IF
|
||||
RETURN
|
||||
*
|
||||
* End of ZSTEQR
|
||||
*
|
||||
END
|
||||
98
lib/linalg/zswap.f
Normal file
98
lib/linalg/zswap.f
Normal file
@ -0,0 +1,98 @@
|
||||
*> \brief \b ZSWAP
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE ZSWAP(N,ZX,INCX,ZY,INCY)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER INCX,INCY,N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* COMPLEX*16 ZX(*),ZY(*)
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> ZSWAP interchanges two vectors.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup complex16_blas_level1
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> jack dongarra, 3/11/78.
|
||||
*> modified 12/3/93, array(1) declarations changed to array(*)
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
SUBROUTINE ZSWAP(N,ZX,INCX,ZY,INCY)
|
||||
*
|
||||
* -- Reference BLAS level1 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER INCX,INCY,N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
COMPLEX*16 ZX(*),ZY(*)
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Local Scalars ..
|
||||
COMPLEX*16 ZTEMP
|
||||
INTEGER I,IX,IY
|
||||
* ..
|
||||
IF (N.LE.0) RETURN
|
||||
IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN
|
||||
*
|
||||
* code for both increments equal to 1
|
||||
DO I = 1,N
|
||||
ZTEMP = ZX(I)
|
||||
ZX(I) = ZY(I)
|
||||
ZY(I) = ZTEMP
|
||||
END DO
|
||||
ELSE
|
||||
*
|
||||
* code for unequal increments or equal increments not equal
|
||||
* to 1
|
||||
*
|
||||
IX = 1
|
||||
IY = 1
|
||||
IF (INCX.LT.0) IX = (-N+1)*INCX + 1
|
||||
IF (INCY.LT.0) IY = (-N+1)*INCY + 1
|
||||
DO I = 1,N
|
||||
ZTEMP = ZX(IX)
|
||||
ZX(IX) = ZY(IY)
|
||||
ZY(IY) = ZTEMP
|
||||
IX = IX + INCX
|
||||
IY = IY + INCY
|
||||
END DO
|
||||
END IF
|
||||
RETURN
|
||||
END
|
||||
452
lib/linalg/ztrmm.f
Normal file
452
lib/linalg/ztrmm.f
Normal file
@ -0,0 +1,452 @@
|
||||
*> \brief \b ZTRMM
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE ZTRMM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* COMPLEX*16 ALPHA
|
||||
* INTEGER LDA,LDB,M,N
|
||||
* CHARACTER DIAG,SIDE,TRANSA,UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* COMPLEX*16 A(LDA,*),B(LDB,*)
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> ZTRMM performs one of the matrix-matrix operations
|
||||
*>
|
||||
*> B := alpha*op( A )*B, or B := alpha*B*op( A )
|
||||
*>
|
||||
*> where alpha is a scalar, B is an m by n matrix, A is a unit, or
|
||||
*> non-unit, upper or lower triangular matrix and op( A ) is one of
|
||||
*>
|
||||
*> op( A ) = A or op( A ) = A**T or op( A ) = A**H.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] SIDE
|
||||
*> \verbatim
|
||||
*> SIDE is CHARACTER*1
|
||||
*> On entry, SIDE specifies whether op( A ) multiplies B from
|
||||
*> the left or right as follows:
|
||||
*>
|
||||
*> SIDE = 'L' or 'l' B := alpha*op( A )*B.
|
||||
*>
|
||||
*> SIDE = 'R' or 'r' B := alpha*B*op( A ).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] UPLO
|
||||
*> \verbatim
|
||||
*> UPLO is CHARACTER*1
|
||||
*> On entry, UPLO specifies whether the matrix A is an upper or
|
||||
*> lower triangular matrix as follows:
|
||||
*>
|
||||
*> UPLO = 'U' or 'u' A is an upper triangular matrix.
|
||||
*>
|
||||
*> UPLO = 'L' or 'l' A is a lower triangular matrix.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] TRANSA
|
||||
*> \verbatim
|
||||
*> TRANSA is CHARACTER*1
|
||||
*> On entry, TRANSA specifies the form of op( A ) to be used in
|
||||
*> the matrix multiplication as follows:
|
||||
*>
|
||||
*> TRANSA = 'N' or 'n' op( A ) = A.
|
||||
*>
|
||||
*> TRANSA = 'T' or 't' op( A ) = A**T.
|
||||
*>
|
||||
*> TRANSA = 'C' or 'c' op( A ) = A**H.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] DIAG
|
||||
*> \verbatim
|
||||
*> DIAG is CHARACTER*1
|
||||
*> On entry, DIAG specifies whether or not A is unit triangular
|
||||
*> as follows:
|
||||
*>
|
||||
*> DIAG = 'U' or 'u' A is assumed to be unit triangular.
|
||||
*>
|
||||
*> DIAG = 'N' or 'n' A is not assumed to be unit
|
||||
*> triangular.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] M
|
||||
*> \verbatim
|
||||
*> M is INTEGER
|
||||
*> On entry, M specifies the number of rows of B. M must be at
|
||||
*> least zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> On entry, N specifies the number of columns of B. N must be
|
||||
*> at least zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] ALPHA
|
||||
*> \verbatim
|
||||
*> ALPHA is COMPLEX*16
|
||||
*> On entry, ALPHA specifies the scalar alpha. When alpha is
|
||||
*> zero then A is not referenced and B need not be set before
|
||||
*> entry.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] A
|
||||
*> \verbatim
|
||||
*> A is COMPLEX*16 array of DIMENSION ( LDA, k ), where k is m
|
||||
*> when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'.
|
||||
*> Before entry with UPLO = 'U' or 'u', the leading k by k
|
||||
*> upper triangular part of the array A must contain the upper
|
||||
*> triangular matrix and the strictly lower triangular part of
|
||||
*> A is not referenced.
|
||||
*> Before entry with UPLO = 'L' or 'l', the leading k by k
|
||||
*> lower triangular part of the array A must contain the lower
|
||||
*> triangular matrix and the strictly upper triangular part of
|
||||
*> A is not referenced.
|
||||
*> Note that when DIAG = 'U' or 'u', the diagonal elements of
|
||||
*> A are not referenced either, but are assumed to be unity.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> On entry, LDA specifies the first dimension of A as declared
|
||||
*> in the calling (sub) program. When SIDE = 'L' or 'l' then
|
||||
*> LDA must be at least max( 1, m ), when SIDE = 'R' or 'r'
|
||||
*> then LDA must be at least max( 1, n ).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] B
|
||||
*> \verbatim
|
||||
*> B is (input/output) COMPLEX*16 array of DIMENSION ( LDB, n ).
|
||||
*> Before entry, the leading m by n part of the array B must
|
||||
*> contain the matrix B, and on exit is overwritten by the
|
||||
*> transformed matrix.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDB
|
||||
*> \verbatim
|
||||
*> LDB is INTEGER
|
||||
*> On entry, LDB specifies the first dimension of B as declared
|
||||
*> in the calling (sub) program. LDB must be at least
|
||||
*> max( 1, m ).
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup complex16_blas_level3
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> Level 3 Blas routine.
|
||||
*>
|
||||
*> -- Written on 8-February-1989.
|
||||
*> Jack Dongarra, Argonne National Laboratory.
|
||||
*> Iain Duff, AERE Harwell.
|
||||
*> Jeremy Du Croz, Numerical Algorithms Group Ltd.
|
||||
*> Sven Hammarling, Numerical Algorithms Group Ltd.
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
SUBROUTINE ZTRMM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB)
|
||||
*
|
||||
* -- Reference BLAS level3 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
COMPLEX*16 ALPHA
|
||||
INTEGER LDA,LDB,M,N
|
||||
CHARACTER DIAG,SIDE,TRANSA,UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
COMPLEX*16 A(LDA,*),B(LDB,*)
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
EXTERNAL LSAME
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC DCONJG,MAX
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
COMPLEX*16 TEMP
|
||||
INTEGER I,INFO,J,K,NROWA
|
||||
LOGICAL LSIDE,NOCONJ,NOUNIT,UPPER
|
||||
* ..
|
||||
* .. Parameters ..
|
||||
COMPLEX*16 ONE
|
||||
PARAMETER (ONE= (1.0D+0,0.0D+0))
|
||||
COMPLEX*16 ZERO
|
||||
PARAMETER (ZERO= (0.0D+0,0.0D+0))
|
||||
* ..
|
||||
*
|
||||
* Test the input parameters.
|
||||
*
|
||||
LSIDE = LSAME(SIDE,'L')
|
||||
IF (LSIDE) THEN
|
||||
NROWA = M
|
||||
ELSE
|
||||
NROWA = N
|
||||
END IF
|
||||
NOCONJ = LSAME(TRANSA,'T')
|
||||
NOUNIT = LSAME(DIAG,'N')
|
||||
UPPER = LSAME(UPLO,'U')
|
||||
*
|
||||
INFO = 0
|
||||
IF ((.NOT.LSIDE) .AND. (.NOT.LSAME(SIDE,'R'))) THEN
|
||||
INFO = 1
|
||||
ELSE IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN
|
||||
INFO = 2
|
||||
ELSE IF ((.NOT.LSAME(TRANSA,'N')) .AND.
|
||||
+ (.NOT.LSAME(TRANSA,'T')) .AND.
|
||||
+ (.NOT.LSAME(TRANSA,'C'))) THEN
|
||||
INFO = 3
|
||||
ELSE IF ((.NOT.LSAME(DIAG,'U')) .AND. (.NOT.LSAME(DIAG,'N'))) THEN
|
||||
INFO = 4
|
||||
ELSE IF (M.LT.0) THEN
|
||||
INFO = 5
|
||||
ELSE IF (N.LT.0) THEN
|
||||
INFO = 6
|
||||
ELSE IF (LDA.LT.MAX(1,NROWA)) THEN
|
||||
INFO = 9
|
||||
ELSE IF (LDB.LT.MAX(1,M)) THEN
|
||||
INFO = 11
|
||||
END IF
|
||||
IF (INFO.NE.0) THEN
|
||||
CALL XERBLA('ZTRMM ',INFO)
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible.
|
||||
*
|
||||
IF (M.EQ.0 .OR. N.EQ.0) RETURN
|
||||
*
|
||||
* And when alpha.eq.zero.
|
||||
*
|
||||
IF (ALPHA.EQ.ZERO) THEN
|
||||
DO 20 J = 1,N
|
||||
DO 10 I = 1,M
|
||||
B(I,J) = ZERO
|
||||
10 CONTINUE
|
||||
20 CONTINUE
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Start the operations.
|
||||
*
|
||||
IF (LSIDE) THEN
|
||||
IF (LSAME(TRANSA,'N')) THEN
|
||||
*
|
||||
* Form B := alpha*A*B.
|
||||
*
|
||||
IF (UPPER) THEN
|
||||
DO 50 J = 1,N
|
||||
DO 40 K = 1,M
|
||||
IF (B(K,J).NE.ZERO) THEN
|
||||
TEMP = ALPHA*B(K,J)
|
||||
DO 30 I = 1,K - 1
|
||||
B(I,J) = B(I,J) + TEMP*A(I,K)
|
||||
30 CONTINUE
|
||||
IF (NOUNIT) TEMP = TEMP*A(K,K)
|
||||
B(K,J) = TEMP
|
||||
END IF
|
||||
40 CONTINUE
|
||||
50 CONTINUE
|
||||
ELSE
|
||||
DO 80 J = 1,N
|
||||
DO 70 K = M,1,-1
|
||||
IF (B(K,J).NE.ZERO) THEN
|
||||
TEMP = ALPHA*B(K,J)
|
||||
B(K,J) = TEMP
|
||||
IF (NOUNIT) B(K,J) = B(K,J)*A(K,K)
|
||||
DO 60 I = K + 1,M
|
||||
B(I,J) = B(I,J) + TEMP*A(I,K)
|
||||
60 CONTINUE
|
||||
END IF
|
||||
70 CONTINUE
|
||||
80 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
*
|
||||
* Form B := alpha*A**T*B or B := alpha*A**H*B.
|
||||
*
|
||||
IF (UPPER) THEN
|
||||
DO 120 J = 1,N
|
||||
DO 110 I = M,1,-1
|
||||
TEMP = B(I,J)
|
||||
IF (NOCONJ) THEN
|
||||
IF (NOUNIT) TEMP = TEMP*A(I,I)
|
||||
DO 90 K = 1,I - 1
|
||||
TEMP = TEMP + A(K,I)*B(K,J)
|
||||
90 CONTINUE
|
||||
ELSE
|
||||
IF (NOUNIT) TEMP = TEMP*DCONJG(A(I,I))
|
||||
DO 100 K = 1,I - 1
|
||||
TEMP = TEMP + DCONJG(A(K,I))*B(K,J)
|
||||
100 CONTINUE
|
||||
END IF
|
||||
B(I,J) = ALPHA*TEMP
|
||||
110 CONTINUE
|
||||
120 CONTINUE
|
||||
ELSE
|
||||
DO 160 J = 1,N
|
||||
DO 150 I = 1,M
|
||||
TEMP = B(I,J)
|
||||
IF (NOCONJ) THEN
|
||||
IF (NOUNIT) TEMP = TEMP*A(I,I)
|
||||
DO 130 K = I + 1,M
|
||||
TEMP = TEMP + A(K,I)*B(K,J)
|
||||
130 CONTINUE
|
||||
ELSE
|
||||
IF (NOUNIT) TEMP = TEMP*DCONJG(A(I,I))
|
||||
DO 140 K = I + 1,M
|
||||
TEMP = TEMP + DCONJG(A(K,I))*B(K,J)
|
||||
140 CONTINUE
|
||||
END IF
|
||||
B(I,J) = ALPHA*TEMP
|
||||
150 CONTINUE
|
||||
160 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
ELSE
|
||||
IF (LSAME(TRANSA,'N')) THEN
|
||||
*
|
||||
* Form B := alpha*B*A.
|
||||
*
|
||||
IF (UPPER) THEN
|
||||
DO 200 J = N,1,-1
|
||||
TEMP = ALPHA
|
||||
IF (NOUNIT) TEMP = TEMP*A(J,J)
|
||||
DO 170 I = 1,M
|
||||
B(I,J) = TEMP*B(I,J)
|
||||
170 CONTINUE
|
||||
DO 190 K = 1,J - 1
|
||||
IF (A(K,J).NE.ZERO) THEN
|
||||
TEMP = ALPHA*A(K,J)
|
||||
DO 180 I = 1,M
|
||||
B(I,J) = B(I,J) + TEMP*B(I,K)
|
||||
180 CONTINUE
|
||||
END IF
|
||||
190 CONTINUE
|
||||
200 CONTINUE
|
||||
ELSE
|
||||
DO 240 J = 1,N
|
||||
TEMP = ALPHA
|
||||
IF (NOUNIT) TEMP = TEMP*A(J,J)
|
||||
DO 210 I = 1,M
|
||||
B(I,J) = TEMP*B(I,J)
|
||||
210 CONTINUE
|
||||
DO 230 K = J + 1,N
|
||||
IF (A(K,J).NE.ZERO) THEN
|
||||
TEMP = ALPHA*A(K,J)
|
||||
DO 220 I = 1,M
|
||||
B(I,J) = B(I,J) + TEMP*B(I,K)
|
||||
220 CONTINUE
|
||||
END IF
|
||||
230 CONTINUE
|
||||
240 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
*
|
||||
* Form B := alpha*B*A**T or B := alpha*B*A**H.
|
||||
*
|
||||
IF (UPPER) THEN
|
||||
DO 280 K = 1,N
|
||||
DO 260 J = 1,K - 1
|
||||
IF (A(J,K).NE.ZERO) THEN
|
||||
IF (NOCONJ) THEN
|
||||
TEMP = ALPHA*A(J,K)
|
||||
ELSE
|
||||
TEMP = ALPHA*DCONJG(A(J,K))
|
||||
END IF
|
||||
DO 250 I = 1,M
|
||||
B(I,J) = B(I,J) + TEMP*B(I,K)
|
||||
250 CONTINUE
|
||||
END IF
|
||||
260 CONTINUE
|
||||
TEMP = ALPHA
|
||||
IF (NOUNIT) THEN
|
||||
IF (NOCONJ) THEN
|
||||
TEMP = TEMP*A(K,K)
|
||||
ELSE
|
||||
TEMP = TEMP*DCONJG(A(K,K))
|
||||
END IF
|
||||
END IF
|
||||
IF (TEMP.NE.ONE) THEN
|
||||
DO 270 I = 1,M
|
||||
B(I,K) = TEMP*B(I,K)
|
||||
270 CONTINUE
|
||||
END IF
|
||||
280 CONTINUE
|
||||
ELSE
|
||||
DO 320 K = N,1,-1
|
||||
DO 300 J = K + 1,N
|
||||
IF (A(J,K).NE.ZERO) THEN
|
||||
IF (NOCONJ) THEN
|
||||
TEMP = ALPHA*A(J,K)
|
||||
ELSE
|
||||
TEMP = ALPHA*DCONJG(A(J,K))
|
||||
END IF
|
||||
DO 290 I = 1,M
|
||||
B(I,J) = B(I,J) + TEMP*B(I,K)
|
||||
290 CONTINUE
|
||||
END IF
|
||||
300 CONTINUE
|
||||
TEMP = ALPHA
|
||||
IF (NOUNIT) THEN
|
||||
IF (NOCONJ) THEN
|
||||
TEMP = TEMP*A(K,K)
|
||||
ELSE
|
||||
TEMP = TEMP*DCONJG(A(K,K))
|
||||
END IF
|
||||
END IF
|
||||
IF (TEMP.NE.ONE) THEN
|
||||
DO 310 I = 1,M
|
||||
B(I,K) = TEMP*B(I,K)
|
||||
310 CONTINUE
|
||||
END IF
|
||||
320 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of ZTRMM .
|
||||
*
|
||||
END
|
||||
373
lib/linalg/ztrmv.f
Normal file
373
lib/linalg/ztrmv.f
Normal file
@ -0,0 +1,373 @@
|
||||
*> \brief \b ZTRMV
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE ZTRMV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER INCX,LDA,N
|
||||
* CHARACTER DIAG,TRANS,UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* COMPLEX*16 A(LDA,*),X(*)
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> ZTRMV performs one of the matrix-vector operations
|
||||
*>
|
||||
*> x := A*x, or x := A**T*x, or x := A**H*x,
|
||||
*>
|
||||
*> where x is an n element vector and A is an n by n unit, or non-unit,
|
||||
*> upper or lower triangular matrix.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] UPLO
|
||||
*> \verbatim
|
||||
*> UPLO is CHARACTER*1
|
||||
*> On entry, UPLO specifies whether the matrix is an upper or
|
||||
*> lower triangular matrix as follows:
|
||||
*>
|
||||
*> UPLO = 'U' or 'u' A is an upper triangular matrix.
|
||||
*>
|
||||
*> UPLO = 'L' or 'l' A is a lower triangular matrix.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] TRANS
|
||||
*> \verbatim
|
||||
*> TRANS is CHARACTER*1
|
||||
*> On entry, TRANS specifies the operation to be performed as
|
||||
*> follows:
|
||||
*>
|
||||
*> TRANS = 'N' or 'n' x := A*x.
|
||||
*>
|
||||
*> TRANS = 'T' or 't' x := A**T*x.
|
||||
*>
|
||||
*> TRANS = 'C' or 'c' x := A**H*x.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] DIAG
|
||||
*> \verbatim
|
||||
*> DIAG is CHARACTER*1
|
||||
*> On entry, DIAG specifies whether or not A is unit
|
||||
*> triangular as follows:
|
||||
*>
|
||||
*> DIAG = 'U' or 'u' A is assumed to be unit triangular.
|
||||
*>
|
||||
*> DIAG = 'N' or 'n' A is not assumed to be unit
|
||||
*> triangular.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> On entry, N specifies the order of the matrix A.
|
||||
*> N must be at least zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] A
|
||||
*> \verbatim
|
||||
*> A is COMPLEX*16 array of DIMENSION ( LDA, n ).
|
||||
*> Before entry with UPLO = 'U' or 'u', the leading n by n
|
||||
*> upper triangular part of the array A must contain the upper
|
||||
*> triangular matrix and the strictly lower triangular part of
|
||||
*> A is not referenced.
|
||||
*> Before entry with UPLO = 'L' or 'l', the leading n by n
|
||||
*> lower triangular part of the array A must contain the lower
|
||||
*> triangular matrix and the strictly upper triangular part of
|
||||
*> A is not referenced.
|
||||
*> Note that when DIAG = 'U' or 'u', the diagonal elements of
|
||||
*> A are not referenced either, but are assumed to be unity.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> On entry, LDA specifies the first dimension of A as declared
|
||||
*> in the calling (sub) program. LDA must be at least
|
||||
*> max( 1, n ).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] X
|
||||
*> \verbatim
|
||||
*> X is (input/output) COMPLEX*16 array of dimension at least
|
||||
*> ( 1 + ( n - 1 )*abs( INCX ) ).
|
||||
*> Before entry, the incremented array X must contain the n
|
||||
*> element vector x. On exit, X is overwritten with the
|
||||
*> tranformed vector x.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] INCX
|
||||
*> \verbatim
|
||||
*> INCX is INTEGER
|
||||
*> On entry, INCX specifies the increment for the elements of
|
||||
*> X. INCX must not be zero.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup complex16_blas_level2
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> Level 2 Blas routine.
|
||||
*> The vector and matrix arguments are not referenced when N = 0, or M = 0
|
||||
*>
|
||||
*> -- Written on 22-October-1986.
|
||||
*> Jack Dongarra, Argonne National Lab.
|
||||
*> Jeremy Du Croz, Nag Central Office.
|
||||
*> Sven Hammarling, Nag Central Office.
|
||||
*> Richard Hanson, Sandia National Labs.
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
SUBROUTINE ZTRMV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX)
|
||||
*
|
||||
* -- Reference BLAS level2 routine (version 3.4.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER INCX,LDA,N
|
||||
CHARACTER DIAG,TRANS,UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
COMPLEX*16 A(LDA,*),X(*)
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
COMPLEX*16 ZERO
|
||||
PARAMETER (ZERO= (0.0D+0,0.0D+0))
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
COMPLEX*16 TEMP
|
||||
INTEGER I,INFO,IX,J,JX,KX
|
||||
LOGICAL NOCONJ,NOUNIT
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
EXTERNAL LSAME
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC DCONJG,MAX
|
||||
* ..
|
||||
*
|
||||
* Test the input parameters.
|
||||
*
|
||||
INFO = 0
|
||||
IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
|
||||
INFO = 1
|
||||
ELSE IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND.
|
||||
+ .NOT.LSAME(TRANS,'C')) THEN
|
||||
INFO = 2
|
||||
ELSE IF (.NOT.LSAME(DIAG,'U') .AND. .NOT.LSAME(DIAG,'N')) THEN
|
||||
INFO = 3
|
||||
ELSE IF (N.LT.0) THEN
|
||||
INFO = 4
|
||||
ELSE IF (LDA.LT.MAX(1,N)) THEN
|
||||
INFO = 6
|
||||
ELSE IF (INCX.EQ.0) THEN
|
||||
INFO = 8
|
||||
END IF
|
||||
IF (INFO.NE.0) THEN
|
||||
CALL XERBLA('ZTRMV ',INFO)
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible.
|
||||
*
|
||||
IF (N.EQ.0) RETURN
|
||||
*
|
||||
NOCONJ = LSAME(TRANS,'T')
|
||||
NOUNIT = LSAME(DIAG,'N')
|
||||
*
|
||||
* Set up the start point in X if the increment is not unity. This
|
||||
* will be ( N - 1 )*INCX too small for descending loops.
|
||||
*
|
||||
IF (INCX.LE.0) THEN
|
||||
KX = 1 - (N-1)*INCX
|
||||
ELSE IF (INCX.NE.1) THEN
|
||||
KX = 1
|
||||
END IF
|
||||
*
|
||||
* Start the operations. In this version the elements of A are
|
||||
* accessed sequentially with one pass through A.
|
||||
*
|
||||
IF (LSAME(TRANS,'N')) THEN
|
||||
*
|
||||
* Form x := A*x.
|
||||
*
|
||||
IF (LSAME(UPLO,'U')) THEN
|
||||
IF (INCX.EQ.1) THEN
|
||||
DO 20 J = 1,N
|
||||
IF (X(J).NE.ZERO) THEN
|
||||
TEMP = X(J)
|
||||
DO 10 I = 1,J - 1
|
||||
X(I) = X(I) + TEMP*A(I,J)
|
||||
10 CONTINUE
|
||||
IF (NOUNIT) X(J) = X(J)*A(J,J)
|
||||
END IF
|
||||
20 CONTINUE
|
||||
ELSE
|
||||
JX = KX
|
||||
DO 40 J = 1,N
|
||||
IF (X(JX).NE.ZERO) THEN
|
||||
TEMP = X(JX)
|
||||
IX = KX
|
||||
DO 30 I = 1,J - 1
|
||||
X(IX) = X(IX) + TEMP*A(I,J)
|
||||
IX = IX + INCX
|
||||
30 CONTINUE
|
||||
IF (NOUNIT) X(JX) = X(JX)*A(J,J)
|
||||
END IF
|
||||
JX = JX + INCX
|
||||
40 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
IF (INCX.EQ.1) THEN
|
||||
DO 60 J = N,1,-1
|
||||
IF (X(J).NE.ZERO) THEN
|
||||
TEMP = X(J)
|
||||
DO 50 I = N,J + 1,-1
|
||||
X(I) = X(I) + TEMP*A(I,J)
|
||||
50 CONTINUE
|
||||
IF (NOUNIT) X(J) = X(J)*A(J,J)
|
||||
END IF
|
||||
60 CONTINUE
|
||||
ELSE
|
||||
KX = KX + (N-1)*INCX
|
||||
JX = KX
|
||||
DO 80 J = N,1,-1
|
||||
IF (X(JX).NE.ZERO) THEN
|
||||
TEMP = X(JX)
|
||||
IX = KX
|
||||
DO 70 I = N,J + 1,-1
|
||||
X(IX) = X(IX) + TEMP*A(I,J)
|
||||
IX = IX - INCX
|
||||
70 CONTINUE
|
||||
IF (NOUNIT) X(JX) = X(JX)*A(J,J)
|
||||
END IF
|
||||
JX = JX - INCX
|
||||
80 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
ELSE
|
||||
*
|
||||
* Form x := A**T*x or x := A**H*x.
|
||||
*
|
||||
IF (LSAME(UPLO,'U')) THEN
|
||||
IF (INCX.EQ.1) THEN
|
||||
DO 110 J = N,1,-1
|
||||
TEMP = X(J)
|
||||
IF (NOCONJ) THEN
|
||||
IF (NOUNIT) TEMP = TEMP*A(J,J)
|
||||
DO 90 I = J - 1,1,-1
|
||||
TEMP = TEMP + A(I,J)*X(I)
|
||||
90 CONTINUE
|
||||
ELSE
|
||||
IF (NOUNIT) TEMP = TEMP*DCONJG(A(J,J))
|
||||
DO 100 I = J - 1,1,-1
|
||||
TEMP = TEMP + DCONJG(A(I,J))*X(I)
|
||||
100 CONTINUE
|
||||
END IF
|
||||
X(J) = TEMP
|
||||
110 CONTINUE
|
||||
ELSE
|
||||
JX = KX + (N-1)*INCX
|
||||
DO 140 J = N,1,-1
|
||||
TEMP = X(JX)
|
||||
IX = JX
|
||||
IF (NOCONJ) THEN
|
||||
IF (NOUNIT) TEMP = TEMP*A(J,J)
|
||||
DO 120 I = J - 1,1,-1
|
||||
IX = IX - INCX
|
||||
TEMP = TEMP + A(I,J)*X(IX)
|
||||
120 CONTINUE
|
||||
ELSE
|
||||
IF (NOUNIT) TEMP = TEMP*DCONJG(A(J,J))
|
||||
DO 130 I = J - 1,1,-1
|
||||
IX = IX - INCX
|
||||
TEMP = TEMP + DCONJG(A(I,J))*X(IX)
|
||||
130 CONTINUE
|
||||
END IF
|
||||
X(JX) = TEMP
|
||||
JX = JX - INCX
|
||||
140 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
IF (INCX.EQ.1) THEN
|
||||
DO 170 J = 1,N
|
||||
TEMP = X(J)
|
||||
IF (NOCONJ) THEN
|
||||
IF (NOUNIT) TEMP = TEMP*A(J,J)
|
||||
DO 150 I = J + 1,N
|
||||
TEMP = TEMP + A(I,J)*X(I)
|
||||
150 CONTINUE
|
||||
ELSE
|
||||
IF (NOUNIT) TEMP = TEMP*DCONJG(A(J,J))
|
||||
DO 160 I = J + 1,N
|
||||
TEMP = TEMP + DCONJG(A(I,J))*X(I)
|
||||
160 CONTINUE
|
||||
END IF
|
||||
X(J) = TEMP
|
||||
170 CONTINUE
|
||||
ELSE
|
||||
JX = KX
|
||||
DO 200 J = 1,N
|
||||
TEMP = X(JX)
|
||||
IX = JX
|
||||
IF (NOCONJ) THEN
|
||||
IF (NOUNIT) TEMP = TEMP*A(J,J)
|
||||
DO 180 I = J + 1,N
|
||||
IX = IX + INCX
|
||||
TEMP = TEMP + A(I,J)*X(IX)
|
||||
180 CONTINUE
|
||||
ELSE
|
||||
IF (NOUNIT) TEMP = TEMP*DCONJG(A(J,J))
|
||||
DO 190 I = J + 1,N
|
||||
IX = IX + INCX
|
||||
TEMP = TEMP + DCONJG(A(I,J))*X(IX)
|
||||
190 CONTINUE
|
||||
END IF
|
||||
X(JX) = TEMP
|
||||
JX = JX + INCX
|
||||
200 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of ZTRMV .
|
||||
*
|
||||
END
|
||||
199
lib/linalg/zung2l.f
Normal file
199
lib/linalg/zung2l.f
Normal file
@ -0,0 +1,199 @@
|
||||
*> \brief \b ZUNG2L generates all or part of the unitary matrix Q from a QL factorization determined by cgeqlf (unblocked algorithm).
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
*> \htmlonly
|
||||
*> Download ZUNG2L + dependencies
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zung2l.f">
|
||||
*> [TGZ]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zung2l.f">
|
||||
*> [ZIP]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zung2l.f">
|
||||
*> [TXT]</a>
|
||||
*> \endhtmlonly
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE ZUNG2L( M, N, K, A, LDA, TAU, WORK, INFO )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER INFO, K, LDA, M, N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> ZUNG2L generates an m by n complex matrix Q with orthonormal columns,
|
||||
*> which is defined as the last n columns of a product of k elementary
|
||||
*> reflectors of order m
|
||||
*>
|
||||
*> Q = H(k) . . . H(2) H(1)
|
||||
*>
|
||||
*> as returned by ZGEQLF.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] M
|
||||
*> \verbatim
|
||||
*> M is INTEGER
|
||||
*> The number of rows of the matrix Q. M >= 0.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> The number of columns of the matrix Q. M >= N >= 0.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] K
|
||||
*> \verbatim
|
||||
*> K is INTEGER
|
||||
*> The number of elementary reflectors whose product defines the
|
||||
*> matrix Q. N >= K >= 0.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] A
|
||||
*> \verbatim
|
||||
*> A is COMPLEX*16 array, dimension (LDA,N)
|
||||
*> On entry, the (n-k+i)-th column must contain the vector which
|
||||
*> defines the elementary reflector H(i), for i = 1,2,...,k, as
|
||||
*> returned by ZGEQLF in the last k columns of its array
|
||||
*> argument A.
|
||||
*> On exit, the m-by-n matrix Q.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> The first dimension of the array A. LDA >= max(1,M).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] TAU
|
||||
*> \verbatim
|
||||
*> TAU is COMPLEX*16 array, dimension (K)
|
||||
*> TAU(i) must contain the scalar factor of the elementary
|
||||
*> reflector H(i), as returned by ZGEQLF.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] WORK
|
||||
*> \verbatim
|
||||
*> WORK is COMPLEX*16 array, dimension (N)
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] INFO
|
||||
*> \verbatim
|
||||
*> INFO is INTEGER
|
||||
*> = 0: successful exit
|
||||
*> < 0: if INFO = -i, the i-th argument has an illegal value
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date September 2012
|
||||
*
|
||||
*> \ingroup complex16OTHERcomputational
|
||||
*
|
||||
* =====================================================================
|
||||
SUBROUTINE ZUNG2L( M, N, K, A, LDA, TAU, WORK, INFO )
|
||||
*
|
||||
* -- LAPACK computational routine (version 3.4.2) --
|
||||
* -- 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 ..
|
||||
INTEGER INFO, K, LDA, M, N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
COMPLEX*16 ONE, ZERO
|
||||
PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ),
|
||||
$ ZERO = ( 0.0D+0, 0.0D+0 ) )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
INTEGER I, II, J, L
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA, ZLARF, ZSCAL
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC MAX
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* Test the input arguments
|
||||
*
|
||||
INFO = 0
|
||||
IF( M.LT.0 ) THEN
|
||||
INFO = -1
|
||||
ELSE IF( N.LT.0 .OR. N.GT.M ) THEN
|
||||
INFO = -2
|
||||
ELSE IF( K.LT.0 .OR. K.GT.N ) THEN
|
||||
INFO = -3
|
||||
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
|
||||
INFO = -5
|
||||
END IF
|
||||
IF( INFO.NE.0 ) THEN
|
||||
CALL XERBLA( 'ZUNG2L', -INFO )
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible
|
||||
*
|
||||
IF( N.LE.0 )
|
||||
$ RETURN
|
||||
*
|
||||
* Initialise columns 1:n-k to columns of the unit matrix
|
||||
*
|
||||
DO 20 J = 1, N - K
|
||||
DO 10 L = 1, M
|
||||
A( L, J ) = ZERO
|
||||
10 CONTINUE
|
||||
A( M-N+J, J ) = ONE
|
||||
20 CONTINUE
|
||||
*
|
||||
DO 40 I = 1, K
|
||||
II = N - K + I
|
||||
*
|
||||
* 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 ZSCAL( M-N+II-1, -TAU( I ), A( 1, II ), 1 )
|
||||
A( M-N+II, II ) = ONE - TAU( I )
|
||||
*
|
||||
* Set A(m-k+i+1:m,n-k+i) to zero
|
||||
*
|
||||
DO 30 L = M - N + II + 1, M
|
||||
A( L, II ) = ZERO
|
||||
30 CONTINUE
|
||||
40 CONTINUE
|
||||
RETURN
|
||||
*
|
||||
* End of ZUNG2L
|
||||
*
|
||||
END
|
||||
201
lib/linalg/zung2r.f
Normal file
201
lib/linalg/zung2r.f
Normal file
@ -0,0 +1,201 @@
|
||||
*> \brief \b ZUNG2R
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
*> \htmlonly
|
||||
*> Download ZUNG2R + dependencies
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zung2r.f">
|
||||
*> [TGZ]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zung2r.f">
|
||||
*> [ZIP]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zung2r.f">
|
||||
*> [TXT]</a>
|
||||
*> \endhtmlonly
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE ZUNG2R( M, N, K, A, LDA, TAU, WORK, INFO )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER INFO, K, LDA, M, N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> ZUNG2R generates an m by n complex matrix Q with orthonormal columns,
|
||||
*> which is defined as the first n columns of a product of k elementary
|
||||
*> reflectors of order m
|
||||
*>
|
||||
*> Q = H(1) H(2) . . . H(k)
|
||||
*>
|
||||
*> as returned by ZGEQRF.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] M
|
||||
*> \verbatim
|
||||
*> M is INTEGER
|
||||
*> The number of rows of the matrix Q. M >= 0.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> The number of columns of the matrix Q. M >= N >= 0.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] K
|
||||
*> \verbatim
|
||||
*> K is INTEGER
|
||||
*> The number of elementary reflectors whose product defines the
|
||||
*> matrix Q. N >= K >= 0.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] A
|
||||
*> \verbatim
|
||||
*> A is COMPLEX*16 array, dimension (LDA,N)
|
||||
*> On entry, the i-th column must contain the vector which
|
||||
*> defines the elementary reflector H(i), for i = 1,2,...,k, as
|
||||
*> returned by ZGEQRF in the first k columns of its array
|
||||
*> argument A.
|
||||
*> On exit, the m by n matrix Q.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> The first dimension of the array A. LDA >= max(1,M).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] TAU
|
||||
*> \verbatim
|
||||
*> TAU is COMPLEX*16 array, dimension (K)
|
||||
*> TAU(i) must contain the scalar factor of the elementary
|
||||
*> reflector H(i), as returned by ZGEQRF.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] WORK
|
||||
*> \verbatim
|
||||
*> WORK is COMPLEX*16 array, dimension (N)
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] INFO
|
||||
*> \verbatim
|
||||
*> INFO is INTEGER
|
||||
*> = 0: successful exit
|
||||
*> < 0: if INFO = -i, the i-th argument has an illegal value
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup complex16OTHERcomputational
|
||||
*
|
||||
* =====================================================================
|
||||
SUBROUTINE ZUNG2R( M, N, K, A, LDA, TAU, WORK, INFO )
|
||||
*
|
||||
* -- LAPACK computational routine (version 3.4.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER INFO, K, LDA, M, N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
COMPLEX*16 ONE, ZERO
|
||||
PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ),
|
||||
$ ZERO = ( 0.0D+0, 0.0D+0 ) )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
INTEGER I, J, L
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA, ZLARF, ZSCAL
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC MAX
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* Test the input arguments
|
||||
*
|
||||
INFO = 0
|
||||
IF( M.LT.0 ) THEN
|
||||
INFO = -1
|
||||
ELSE IF( N.LT.0 .OR. N.GT.M ) THEN
|
||||
INFO = -2
|
||||
ELSE IF( K.LT.0 .OR. K.GT.N ) THEN
|
||||
INFO = -3
|
||||
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
|
||||
INFO = -5
|
||||
END IF
|
||||
IF( INFO.NE.0 ) THEN
|
||||
CALL XERBLA( 'ZUNG2R', -INFO )
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible
|
||||
*
|
||||
IF( N.LE.0 )
|
||||
$ RETURN
|
||||
*
|
||||
* Initialise columns k+1:n to columns of the unit matrix
|
||||
*
|
||||
DO 20 J = K + 1, N
|
||||
DO 10 L = 1, M
|
||||
A( L, J ) = ZERO
|
||||
10 CONTINUE
|
||||
A( J, J ) = ONE
|
||||
20 CONTINUE
|
||||
*
|
||||
DO 40 I = K, 1, -1
|
||||
*
|
||||
* 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 )
|
||||
END IF
|
||||
IF( I.LT.M )
|
||||
$ CALL ZSCAL( M-I, -TAU( I ), A( I+1, I ), 1 )
|
||||
A( I, I ) = ONE - TAU( I )
|
||||
*
|
||||
* Set A(1:i-1,i) to zero
|
||||
*
|
||||
DO 30 L = 1, I - 1
|
||||
A( L, I ) = ZERO
|
||||
30 CONTINUE
|
||||
40 CONTINUE
|
||||
RETURN
|
||||
*
|
||||
* End of ZUNG2R
|
||||
*
|
||||
END
|
||||
207
lib/linalg/zungl2.f
Normal file
207
lib/linalg/zungl2.f
Normal file
@ -0,0 +1,207 @@
|
||||
*> \brief \b ZUNGL2 generates all or part of the unitary matrix Q from an LQ factorization determined by cgelqf (unblocked algorithm).
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
*> \htmlonly
|
||||
*> Download ZUNGL2 + dependencies
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zungl2.f">
|
||||
*> [TGZ]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zungl2.f">
|
||||
*> [ZIP]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zungl2.f">
|
||||
*> [TXT]</a>
|
||||
*> \endhtmlonly
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE ZUNGL2( M, N, K, A, LDA, TAU, WORK, INFO )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER INFO, K, LDA, M, N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> ZUNGL2 generates an m-by-n complex matrix Q with orthonormal rows,
|
||||
*> which is defined as the first m rows of a product of k elementary
|
||||
*> reflectors of order n
|
||||
*>
|
||||
*> Q = H(k)**H . . . H(2)**H H(1)**H
|
||||
*>
|
||||
*> as returned by ZGELQF.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] M
|
||||
*> \verbatim
|
||||
*> M is INTEGER
|
||||
*> The number of rows of the matrix Q. M >= 0.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> The number of columns of the matrix Q. N >= M.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] K
|
||||
*> \verbatim
|
||||
*> K is INTEGER
|
||||
*> The number of elementary reflectors whose product defines the
|
||||
*> matrix Q. M >= K >= 0.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] A
|
||||
*> \verbatim
|
||||
*> A is COMPLEX*16 array, dimension (LDA,N)
|
||||
*> On entry, the i-th row must contain the vector which defines
|
||||
*> the elementary reflector H(i), for i = 1,2,...,k, as returned
|
||||
*> by ZGELQF in the first k rows of its array argument A.
|
||||
*> On exit, the m by n matrix Q.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> The first dimension of the array A. LDA >= max(1,M).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] TAU
|
||||
*> \verbatim
|
||||
*> TAU is COMPLEX*16 array, dimension (K)
|
||||
*> TAU(i) must contain the scalar factor of the elementary
|
||||
*> reflector H(i), as returned by ZGELQF.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] WORK
|
||||
*> \verbatim
|
||||
*> WORK is COMPLEX*16 array, dimension (M)
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] INFO
|
||||
*> \verbatim
|
||||
*> INFO is INTEGER
|
||||
*> = 0: successful exit
|
||||
*> < 0: if INFO = -i, the i-th argument has an illegal value
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date September 2012
|
||||
*
|
||||
*> \ingroup complex16OTHERcomputational
|
||||
*
|
||||
* =====================================================================
|
||||
SUBROUTINE ZUNGL2( M, N, K, A, LDA, TAU, WORK, INFO )
|
||||
*
|
||||
* -- LAPACK computational routine (version 3.4.2) --
|
||||
* -- 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 ..
|
||||
INTEGER INFO, K, LDA, M, N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
COMPLEX*16 ONE, ZERO
|
||||
PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ),
|
||||
$ ZERO = ( 0.0D+0, 0.0D+0 ) )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
INTEGER I, J, L
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA, ZLACGV, ZLARF, ZSCAL
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC DCONJG, MAX
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* Test the input arguments
|
||||
*
|
||||
INFO = 0
|
||||
IF( M.LT.0 ) THEN
|
||||
INFO = -1
|
||||
ELSE IF( N.LT.M ) THEN
|
||||
INFO = -2
|
||||
ELSE IF( K.LT.0 .OR. K.GT.M ) THEN
|
||||
INFO = -3
|
||||
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
|
||||
INFO = -5
|
||||
END IF
|
||||
IF( INFO.NE.0 ) THEN
|
||||
CALL XERBLA( 'ZUNGL2', -INFO )
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible
|
||||
*
|
||||
IF( M.LE.0 )
|
||||
$ RETURN
|
||||
*
|
||||
IF( K.LT.M ) THEN
|
||||
*
|
||||
* Initialise rows k+1:m to rows of the unit matrix
|
||||
*
|
||||
DO 20 J = 1, N
|
||||
DO 10 L = K + 1, M
|
||||
A( L, J ) = ZERO
|
||||
10 CONTINUE
|
||||
IF( J.GT.K .AND. J.LE.M )
|
||||
$ A( J, J ) = ONE
|
||||
20 CONTINUE
|
||||
END IF
|
||||
*
|
||||
DO 40 I = K, 1, -1
|
||||
*
|
||||
* Apply H(i)**H to A(i:m,i:n) from the right
|
||||
*
|
||||
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 )
|
||||
END IF
|
||||
CALL ZSCAL( N-I, -TAU( I ), A( I, I+1 ), LDA )
|
||||
CALL ZLACGV( N-I, A( I, I+1 ), LDA )
|
||||
END IF
|
||||
A( I, I ) = ONE - DCONJG( TAU( I ) )
|
||||
*
|
||||
* Set A(i,1:i-1) to zero
|
||||
*
|
||||
DO 30 L = 1, I - 1
|
||||
A( I, L ) = ZERO
|
||||
30 CONTINUE
|
||||
40 CONTINUE
|
||||
RETURN
|
||||
*
|
||||
* End of ZUNGL2
|
||||
*
|
||||
END
|
||||
296
lib/linalg/zungql.f
Normal file
296
lib/linalg/zungql.f
Normal file
@ -0,0 +1,296 @@
|
||||
*> \brief \b ZUNGQL
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
*> \htmlonly
|
||||
*> Download ZUNGQL + dependencies
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zungql.f">
|
||||
*> [TGZ]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zungql.f">
|
||||
*> [ZIP]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zungql.f">
|
||||
*> [TXT]</a>
|
||||
*> \endhtmlonly
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE ZUNGQL( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER INFO, K, LDA, LWORK, M, N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> ZUNGQL generates an M-by-N complex matrix Q with orthonormal columns,
|
||||
*> which is defined as the last N columns of a product of K elementary
|
||||
*> reflectors of order M
|
||||
*>
|
||||
*> Q = H(k) . . . H(2) H(1)
|
||||
*>
|
||||
*> as returned by ZGEQLF.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] M
|
||||
*> \verbatim
|
||||
*> M is INTEGER
|
||||
*> The number of rows of the matrix Q. M >= 0.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> The number of columns of the matrix Q. M >= N >= 0.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] K
|
||||
*> \verbatim
|
||||
*> K is INTEGER
|
||||
*> The number of elementary reflectors whose product defines the
|
||||
*> matrix Q. N >= K >= 0.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] A
|
||||
*> \verbatim
|
||||
*> A is COMPLEX*16 array, dimension (LDA,N)
|
||||
*> On entry, the (n-k+i)-th column must contain the vector which
|
||||
*> defines the elementary reflector H(i), for i = 1,2,...,k, as
|
||||
*> returned by ZGEQLF in the last k columns of its array
|
||||
*> argument A.
|
||||
*> On exit, the M-by-N matrix Q.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> The first dimension of the array A. LDA >= max(1,M).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] TAU
|
||||
*> \verbatim
|
||||
*> TAU is COMPLEX*16 array, dimension (K)
|
||||
*> TAU(i) must contain the scalar factor of the elementary
|
||||
*> reflector H(i), as returned by ZGEQLF.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] WORK
|
||||
*> \verbatim
|
||||
*> WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
|
||||
*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LWORK
|
||||
*> \verbatim
|
||||
*> LWORK is INTEGER
|
||||
*> The dimension of the array WORK. LWORK >= max(1,N).
|
||||
*> For optimum performance LWORK >= N*NB, where NB is the
|
||||
*> optimal blocksize.
|
||||
*>
|
||||
*> If LWORK = -1, then a workspace query is assumed; the routine
|
||||
*> only calculates the optimal size of the WORK array, returns
|
||||
*> this value as the first entry of the WORK array, and no error
|
||||
*> message related to LWORK is issued by XERBLA.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] INFO
|
||||
*> \verbatim
|
||||
*> INFO is INTEGER
|
||||
*> = 0: successful exit
|
||||
*> < 0: if INFO = -i, the i-th argument has an illegal value
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup complex16OTHERcomputational
|
||||
*
|
||||
* =====================================================================
|
||||
SUBROUTINE ZUNGQL( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
|
||||
*
|
||||
* -- LAPACK computational routine (version 3.4.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER INFO, K, LDA, LWORK, M, N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
COMPLEX*16 ZERO
|
||||
PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
LOGICAL LQUERY
|
||||
INTEGER I, IB, IINFO, IWS, J, KK, L, LDWORK, LWKOPT,
|
||||
$ NB, NBMIN, NX
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA, ZLARFB, ZLARFT, ZUNG2L
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC MAX, MIN
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
INTEGER ILAENV
|
||||
EXTERNAL ILAENV
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* Test the input arguments
|
||||
*
|
||||
INFO = 0
|
||||
LQUERY = ( LWORK.EQ.-1 )
|
||||
IF( M.LT.0 ) THEN
|
||||
INFO = -1
|
||||
ELSE IF( N.LT.0 .OR. N.GT.M ) THEN
|
||||
INFO = -2
|
||||
ELSE IF( K.LT.0 .OR. K.GT.N ) THEN
|
||||
INFO = -3
|
||||
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
|
||||
INFO = -5
|
||||
END IF
|
||||
*
|
||||
IF( INFO.EQ.0 ) THEN
|
||||
IF( N.EQ.0 ) THEN
|
||||
LWKOPT = 1
|
||||
ELSE
|
||||
NB = ILAENV( 1, 'ZUNGQL', ' ', M, N, K, -1 )
|
||||
LWKOPT = N*NB
|
||||
END IF
|
||||
WORK( 1 ) = LWKOPT
|
||||
*
|
||||
IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN
|
||||
INFO = -8
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
IF( INFO.NE.0 ) THEN
|
||||
CALL XERBLA( 'ZUNGQL', -INFO )
|
||||
RETURN
|
||||
ELSE IF( LQUERY ) THEN
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible
|
||||
*
|
||||
IF( N.LE.0 ) THEN
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
NBMIN = 2
|
||||
NX = 0
|
||||
IWS = N
|
||||
IF( NB.GT.1 .AND. NB.LT.K ) THEN
|
||||
*
|
||||
* Determine when to cross over from blocked to unblocked code.
|
||||
*
|
||||
NX = MAX( 0, ILAENV( 3, 'ZUNGQL', ' ', M, N, K, -1 ) )
|
||||
IF( NX.LT.K ) THEN
|
||||
*
|
||||
* Determine if workspace is large enough for blocked code.
|
||||
*
|
||||
LDWORK = N
|
||||
IWS = LDWORK*NB
|
||||
IF( LWORK.LT.IWS ) THEN
|
||||
*
|
||||
* Not enough workspace to use optimal NB: reduce NB and
|
||||
* determine the minimum value of NB.
|
||||
*
|
||||
NB = LWORK / LDWORK
|
||||
NBMIN = MAX( 2, ILAENV( 2, 'ZUNGQL', ' ', M, N, K, -1 ) )
|
||||
END IF
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN
|
||||
*
|
||||
* Use blocked code after the first block.
|
||||
* The last kk columns are handled by the block method.
|
||||
*
|
||||
KK = MIN( K, ( ( K-NX+NB-1 ) / NB )*NB )
|
||||
*
|
||||
* Set A(m-kk+1:m,1:n-kk) to zero.
|
||||
*
|
||||
DO 20 J = 1, N - KK
|
||||
DO 10 I = M - KK + 1, M
|
||||
A( I, J ) = ZERO
|
||||
10 CONTINUE
|
||||
20 CONTINUE
|
||||
ELSE
|
||||
KK = 0
|
||||
END IF
|
||||
*
|
||||
* Use unblocked code for the first or only block.
|
||||
*
|
||||
CALL ZUNG2L( M-KK, N-KK, K-KK, A, LDA, TAU, WORK, IINFO )
|
||||
*
|
||||
IF( KK.GT.0 ) THEN
|
||||
*
|
||||
* Use blocked code
|
||||
*
|
||||
DO 50 I = K - KK + 1, K, NB
|
||||
IB = MIN( NB, K-I+1 )
|
||||
IF( N-K+I.GT.1 ) THEN
|
||||
*
|
||||
* Form the triangular factor of the block reflector
|
||||
* H = H(i+ib-1) . . . H(i+1) H(i)
|
||||
*
|
||||
CALL ZLARFT( 'Backward', 'Columnwise', M-K+I+IB-1, IB,
|
||||
$ A( 1, N-K+I ), LDA, TAU( I ), WORK, LDWORK )
|
||||
*
|
||||
* Apply H to A(1:m-k+i+ib-1,1:n-k+i-1) from the left
|
||||
*
|
||||
CALL ZLARFB( 'Left', 'No transpose', 'Backward',
|
||||
$ 'Columnwise', M-K+I+IB-1, N-K+I-1, IB,
|
||||
$ A( 1, N-K+I ), LDA, WORK, LDWORK, A, LDA,
|
||||
$ WORK( IB+1 ), LDWORK )
|
||||
END IF
|
||||
*
|
||||
* Apply H to rows 1:m-k+i+ib-1 of current block
|
||||
*
|
||||
CALL ZUNG2L( M-K+I+IB-1, IB, IB, A( 1, N-K+I ), LDA,
|
||||
$ TAU( I ), WORK, IINFO )
|
||||
*
|
||||
* Set rows m-k+i+ib:m of current block to zero
|
||||
*
|
||||
DO 40 J = N - K + I, N - K + I + IB - 1
|
||||
DO 30 L = M - K + I + IB, M
|
||||
A( L, J ) = ZERO
|
||||
30 CONTINUE
|
||||
40 CONTINUE
|
||||
50 CONTINUE
|
||||
END IF
|
||||
*
|
||||
WORK( 1 ) = IWS
|
||||
RETURN
|
||||
*
|
||||
* End of ZUNGQL
|
||||
*
|
||||
END
|
||||
290
lib/linalg/zungqr.f
Normal file
290
lib/linalg/zungqr.f
Normal file
@ -0,0 +1,290 @@
|
||||
*> \brief \b ZUNGQR
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
*> \htmlonly
|
||||
*> Download ZUNGQR + dependencies
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zungqr.f">
|
||||
*> [TGZ]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zungqr.f">
|
||||
*> [ZIP]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zungqr.f">
|
||||
*> [TXT]</a>
|
||||
*> \endhtmlonly
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE ZUNGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER INFO, K, LDA, LWORK, M, N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> ZUNGQR generates an M-by-N complex matrix Q with orthonormal columns,
|
||||
*> which is defined as the first N columns of a product of K elementary
|
||||
*> reflectors of order M
|
||||
*>
|
||||
*> Q = H(1) H(2) . . . H(k)
|
||||
*>
|
||||
*> as returned by ZGEQRF.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] M
|
||||
*> \verbatim
|
||||
*> M is INTEGER
|
||||
*> The number of rows of the matrix Q. M >= 0.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> The number of columns of the matrix Q. M >= N >= 0.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] K
|
||||
*> \verbatim
|
||||
*> K is INTEGER
|
||||
*> The number of elementary reflectors whose product defines the
|
||||
*> matrix Q. N >= K >= 0.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] A
|
||||
*> \verbatim
|
||||
*> A is COMPLEX*16 array, dimension (LDA,N)
|
||||
*> On entry, the i-th column must contain the vector which
|
||||
*> defines the elementary reflector H(i), for i = 1,2,...,k, as
|
||||
*> returned by ZGEQRF in the first k columns of its array
|
||||
*> argument A.
|
||||
*> On exit, the M-by-N matrix Q.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> The first dimension of the array A. LDA >= max(1,M).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] TAU
|
||||
*> \verbatim
|
||||
*> TAU is COMPLEX*16 array, dimension (K)
|
||||
*> TAU(i) must contain the scalar factor of the elementary
|
||||
*> reflector H(i), as returned by ZGEQRF.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] WORK
|
||||
*> \verbatim
|
||||
*> WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
|
||||
*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LWORK
|
||||
*> \verbatim
|
||||
*> LWORK is INTEGER
|
||||
*> The dimension of the array WORK. LWORK >= max(1,N).
|
||||
*> For optimum performance LWORK >= N*NB, where NB is the
|
||||
*> optimal blocksize.
|
||||
*>
|
||||
*> If LWORK = -1, then a workspace query is assumed; the routine
|
||||
*> only calculates the optimal size of the WORK array, returns
|
||||
*> this value as the first entry of the WORK array, and no error
|
||||
*> message related to LWORK is issued by XERBLA.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] INFO
|
||||
*> \verbatim
|
||||
*> INFO is INTEGER
|
||||
*> = 0: successful exit
|
||||
*> < 0: if INFO = -i, the i-th argument has an illegal value
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date November 2011
|
||||
*
|
||||
*> \ingroup complex16OTHERcomputational
|
||||
*
|
||||
* =====================================================================
|
||||
SUBROUTINE ZUNGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
|
||||
*
|
||||
* -- LAPACK computational routine (version 3.4.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER INFO, K, LDA, LWORK, M, N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
COMPLEX*16 ZERO
|
||||
PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
LOGICAL LQUERY
|
||||
INTEGER I, IB, IINFO, IWS, J, KI, KK, L, LDWORK,
|
||||
$ LWKOPT, NB, NBMIN, NX
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA, ZLARFB, ZLARFT, ZUNG2R
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC MAX, MIN
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
INTEGER ILAENV
|
||||
EXTERNAL ILAENV
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* Test the input arguments
|
||||
*
|
||||
INFO = 0
|
||||
NB = ILAENV( 1, 'ZUNGQR', ' ', M, N, K, -1 )
|
||||
LWKOPT = MAX( 1, N )*NB
|
||||
WORK( 1 ) = LWKOPT
|
||||
LQUERY = ( LWORK.EQ.-1 )
|
||||
IF( M.LT.0 ) THEN
|
||||
INFO = -1
|
||||
ELSE IF( N.LT.0 .OR. N.GT.M ) THEN
|
||||
INFO = -2
|
||||
ELSE IF( K.LT.0 .OR. K.GT.N ) THEN
|
||||
INFO = -3
|
||||
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
|
||||
INFO = -5
|
||||
ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN
|
||||
INFO = -8
|
||||
END IF
|
||||
IF( INFO.NE.0 ) THEN
|
||||
CALL XERBLA( 'ZUNGQR', -INFO )
|
||||
RETURN
|
||||
ELSE IF( LQUERY ) THEN
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible
|
||||
*
|
||||
IF( N.LE.0 ) THEN
|
||||
WORK( 1 ) = 1
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
NBMIN = 2
|
||||
NX = 0
|
||||
IWS = N
|
||||
IF( NB.GT.1 .AND. NB.LT.K ) THEN
|
||||
*
|
||||
* Determine when to cross over from blocked to unblocked code.
|
||||
*
|
||||
NX = MAX( 0, ILAENV( 3, 'ZUNGQR', ' ', M, N, K, -1 ) )
|
||||
IF( NX.LT.K ) THEN
|
||||
*
|
||||
* Determine if workspace is large enough for blocked code.
|
||||
*
|
||||
LDWORK = N
|
||||
IWS = LDWORK*NB
|
||||
IF( LWORK.LT.IWS ) THEN
|
||||
*
|
||||
* Not enough workspace to use optimal NB: reduce NB and
|
||||
* determine the minimum value of NB.
|
||||
*
|
||||
NB = LWORK / LDWORK
|
||||
NBMIN = MAX( 2, ILAENV( 2, 'ZUNGQR', ' ', M, N, K, -1 ) )
|
||||
END IF
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN
|
||||
*
|
||||
* Use blocked code after the last block.
|
||||
* The first kk columns are handled by the block method.
|
||||
*
|
||||
KI = ( ( K-NX-1 ) / NB )*NB
|
||||
KK = MIN( K, KI+NB )
|
||||
*
|
||||
* Set A(1:kk,kk+1:n) to zero.
|
||||
*
|
||||
DO 20 J = KK + 1, N
|
||||
DO 10 I = 1, KK
|
||||
A( I, J ) = ZERO
|
||||
10 CONTINUE
|
||||
20 CONTINUE
|
||||
ELSE
|
||||
KK = 0
|
||||
END IF
|
||||
*
|
||||
* Use unblocked code for the last or only block.
|
||||
*
|
||||
IF( KK.LT.N )
|
||||
$ CALL ZUNG2R( M-KK, N-KK, K-KK, A( KK+1, KK+1 ), LDA,
|
||||
$ TAU( KK+1 ), WORK, IINFO )
|
||||
*
|
||||
IF( KK.GT.0 ) THEN
|
||||
*
|
||||
* Use blocked code
|
||||
*
|
||||
DO 50 I = KI + 1, 1, -NB
|
||||
IB = MIN( NB, K-I+1 )
|
||||
IF( I+IB.LE.N ) THEN
|
||||
*
|
||||
* Form the triangular factor of the block reflector
|
||||
* H = H(i) H(i+1) . . . H(i+ib-1)
|
||||
*
|
||||
CALL ZLARFT( 'Forward', 'Columnwise', M-I+1, IB,
|
||||
$ A( I, I ), LDA, TAU( I ), WORK, LDWORK )
|
||||
*
|
||||
* Apply H to A(i:m,i+ib:n) from the left
|
||||
*
|
||||
CALL ZLARFB( 'Left', 'No transpose', 'Forward',
|
||||
$ 'Columnwise', M-I+1, N-I-IB+1, IB,
|
||||
$ A( I, I ), LDA, WORK, LDWORK, A( I, I+IB ),
|
||||
$ LDA, WORK( IB+1 ), LDWORK )
|
||||
END IF
|
||||
*
|
||||
* Apply H to rows i:m of current block
|
||||
*
|
||||
CALL ZUNG2R( M-I+1, IB, IB, A( I, I ), LDA, TAU( I ), WORK,
|
||||
$ IINFO )
|
||||
*
|
||||
* Set rows 1:i-1 of current block to zero
|
||||
*
|
||||
DO 40 J = I, I + IB - 1
|
||||
DO 30 L = 1, I - 1
|
||||
A( L, J ) = ZERO
|
||||
30 CONTINUE
|
||||
40 CONTINUE
|
||||
50 CONTINUE
|
||||
END IF
|
||||
*
|
||||
WORK( 1 ) = IWS
|
||||
RETURN
|
||||
*
|
||||
* End of ZUNGQR
|
||||
*
|
||||
END
|
||||
256
lib/linalg/zungtr.f
Normal file
256
lib/linalg/zungtr.f
Normal file
@ -0,0 +1,256 @@
|
||||
*> \brief \b ZUNGTR
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
*> \htmlonly
|
||||
*> Download ZUNGTR + dependencies
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zungtr.f">
|
||||
*> [TGZ]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zungtr.f">
|
||||
*> [ZIP]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zungtr.f">
|
||||
*> [TXT]</a>
|
||||
*> \endhtmlonly
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE ZUNGTR( UPLO, N, A, LDA, TAU, WORK, LWORK, INFO )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* CHARACTER UPLO
|
||||
* INTEGER INFO, LDA, LWORK, N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> ZUNGTR generates a complex unitary matrix Q which is defined as the
|
||||
*> product of n-1 elementary reflectors of order N, as returned by
|
||||
*> ZHETRD:
|
||||
*>
|
||||
*> if UPLO = 'U', Q = H(n-1) . . . H(2) H(1),
|
||||
*>
|
||||
*> if UPLO = 'L', Q = H(1) H(2) . . . H(n-1).
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] UPLO
|
||||
*> \verbatim
|
||||
*> UPLO is CHARACTER*1
|
||||
*> = 'U': Upper triangle of A contains elementary reflectors
|
||||
*> from ZHETRD;
|
||||
*> = 'L': Lower triangle of A contains elementary reflectors
|
||||
*> from ZHETRD.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> The order of the matrix Q. N >= 0.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] A
|
||||
*> \verbatim
|
||||
*> A is COMPLEX*16 array, dimension (LDA,N)
|
||||
*> On entry, the vectors which define the elementary reflectors,
|
||||
*> as returned by ZHETRD.
|
||||
*> On exit, the N-by-N unitary matrix Q.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> The leading dimension of the array A. LDA >= N.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] TAU
|
||||
*> \verbatim
|
||||
*> TAU is COMPLEX*16 array, dimension (N-1)
|
||||
*> TAU(i) must contain the scalar factor of the elementary
|
||||
*> reflector H(i), as returned by ZHETRD.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] WORK
|
||||
*> \verbatim
|
||||
*> WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
|
||||
*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LWORK
|
||||
*> \verbatim
|
||||
*> LWORK is INTEGER
|
||||
*> The dimension of the array WORK. LWORK >= N-1.
|
||||
*> For optimum performance LWORK >= (N-1)*NB, where NB is
|
||||
*> the optimal blocksize.
|
||||
*>
|
||||
*> If LWORK = -1, then a workspace query is assumed; the routine
|
||||
*> only calculates the optimal size of the WORK array, returns
|
||||
*> this value as the first entry of the WORK array, and no error
|
||||
*> message related to LWORK is issued by XERBLA.
|
||||
*> \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 November 2011
|
||||
*
|
||||
*> \ingroup complex16OTHERcomputational
|
||||
*
|
||||
* =====================================================================
|
||||
SUBROUTINE ZUNGTR( UPLO, N, A, LDA, TAU, WORK, LWORK, INFO )
|
||||
*
|
||||
* -- LAPACK computational routine (version 3.4.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* November 2011
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
CHARACTER UPLO
|
||||
INTEGER INFO, LDA, LWORK, N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
COMPLEX*16 ZERO, ONE
|
||||
PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ),
|
||||
$ ONE = ( 1.0D+0, 0.0D+0 ) )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
LOGICAL LQUERY, UPPER
|
||||
INTEGER I, IINFO, J, LWKOPT, NB
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
INTEGER ILAENV
|
||||
EXTERNAL LSAME, ILAENV
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA, ZUNGQL, ZUNGQR
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC MAX
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* Test the input arguments
|
||||
*
|
||||
INFO = 0
|
||||
LQUERY = ( LWORK.EQ.-1 )
|
||||
UPPER = LSAME( UPLO, 'U' )
|
||||
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
|
||||
INFO = -1
|
||||
ELSE IF( N.LT.0 ) THEN
|
||||
INFO = -2
|
||||
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
|
||||
INFO = -4
|
||||
ELSE IF( LWORK.LT.MAX( 1, N-1 ) .AND. .NOT.LQUERY ) THEN
|
||||
INFO = -7
|
||||
END IF
|
||||
*
|
||||
IF( INFO.EQ.0 ) THEN
|
||||
IF( UPPER ) THEN
|
||||
NB = ILAENV( 1, 'ZUNGQL', ' ', N-1, N-1, N-1, -1 )
|
||||
ELSE
|
||||
NB = ILAENV( 1, 'ZUNGQR', ' ', N-1, N-1, N-1, -1 )
|
||||
END IF
|
||||
LWKOPT = MAX( 1, N-1 )*NB
|
||||
WORK( 1 ) = LWKOPT
|
||||
END IF
|
||||
*
|
||||
IF( INFO.NE.0 ) THEN
|
||||
CALL XERBLA( 'ZUNGTR', -INFO )
|
||||
RETURN
|
||||
ELSE IF( LQUERY ) THEN
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible
|
||||
*
|
||||
IF( N.EQ.0 ) THEN
|
||||
WORK( 1 ) = 1
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
IF( UPPER ) THEN
|
||||
*
|
||||
* Q was determined by a call to ZHETRD with UPLO = 'U'
|
||||
*
|
||||
* Shift the vectors which define the elementary reflectors one
|
||||
* column to the left, and set the last row and column of Q to
|
||||
* those of the unit matrix
|
||||
*
|
||||
DO 20 J = 1, N - 1
|
||||
DO 10 I = 1, J - 1
|
||||
A( I, J ) = A( I, J+1 )
|
||||
10 CONTINUE
|
||||
A( N, J ) = ZERO
|
||||
20 CONTINUE
|
||||
DO 30 I = 1, N - 1
|
||||
A( I, N ) = ZERO
|
||||
30 CONTINUE
|
||||
A( N, N ) = ONE
|
||||
*
|
||||
* Generate Q(1:n-1,1:n-1)
|
||||
*
|
||||
CALL ZUNGQL( N-1, N-1, N-1, A, LDA, TAU, WORK, LWORK, IINFO )
|
||||
*
|
||||
ELSE
|
||||
*
|
||||
* Q was determined by a call to ZHETRD with UPLO = 'L'.
|
||||
*
|
||||
* Shift the vectors which define the elementary reflectors one
|
||||
* column to the right, and set the first row and column of Q to
|
||||
* those of the unit matrix
|
||||
*
|
||||
DO 50 J = N, 2, -1
|
||||
A( 1, J ) = ZERO
|
||||
DO 40 I = J + 1, N
|
||||
A( I, J ) = A( I, J-1 )
|
||||
40 CONTINUE
|
||||
50 CONTINUE
|
||||
A( 1, 1 ) = ONE
|
||||
DO 60 I = 2, N
|
||||
A( I, 1 ) = ZERO
|
||||
60 CONTINUE
|
||||
IF( N.GT.1 ) THEN
|
||||
*
|
||||
* Generate Q(2:n,2:n)
|
||||
*
|
||||
CALL ZUNGQR( N-1, N-1, N-1, A( 2, 2 ), LDA, TAU, WORK,
|
||||
$ LWORK, IINFO )
|
||||
END IF
|
||||
END IF
|
||||
WORK( 1 ) = LWKOPT
|
||||
RETURN
|
||||
*
|
||||
* End of ZUNGTR
|
||||
*
|
||||
END
|
||||
Reference in New Issue
Block a user