sbbcsd.f slapmr.f sorbdb.f sorbdb1.f sorbdb2.f sorbdb3.f sorbdb4.f
sorbdb5.f sorbdb6.f sorcsd.f sorcsd2by1.f
sgeqrt.f sgeqrt2.f sgeqrt3.f sgemqrt.f
- stpqrt.f stpqrt2.f stpmqrt.f stprfb.f
+ stpqrt.f stpqrt2.f stpmqrt.f stprfb.f
sgelqt.f sgelqt3.f sgemlqt.f
sgetsls.f sgeqr.f slatsqr.f slamtsqr.f sgemqr.f
sgelq.f slaswlq.f slamswlq.f sgemlq.f
dbbcsd.f dlapmr.f dorbdb.f dorbdb1.f dorbdb2.f dorbdb3.f dorbdb4.f
dorbdb5.f dorbdb6.f dorcsd.f dorcsd2by1.f
dgeqrt.f dgeqrt2.f dgeqrt3.f dgemqrt.f
- dtpqrt.f dtpqrt2.f dtpmqrt.f dtprfb.f
+ dtpqrt.f dtpqrt2.f dtpmqrt.f dtprfb.f
dgelqt.f dgelqt3.f dgemlqt.f
dgetsls.f dgeqr.f dlatsqr.f dlamtsqr.f dgemqr.f
dgelq.f dlaswlq.f dlamswlq.f dgemlq.f
-*
+*
* Definition:
* ===========
*
-* SUBROUTINE CGELQ( M, N, A, LDA, WORK1, LWORK1, WORK2, LWORK2,
+* SUBROUTINE CGELQ( M, N, A, LDA, WORK1, LWORK1, WORK2, LWORK2,
* INFO)
-*
+*
* .. Scalar Arguments ..
* INTEGER INFO, LDA, M, N, LWORK1, LWORK2
* ..
* .. Array Arguments ..
* COMPLEX A( LDA, * ), WORK1( * ), WORK2( * )
* ..
-*
+*
*
*> \par Purpose:
* =============
*>
*> \verbatim
-*>
-*> CGELQ computes an LQ factorization of an M-by-N matrix A,
-*> using CLASWLQ when A is short and wide
-*> (N sufficiently greater than M), and otherwise CGELQT:
+*>
+*> CGELQ computes an LQ factorization of an M-by-N matrix A,
+*> using CLASWLQ when A is short and wide
+*> (N sufficiently greater than M), and otherwise CGELQT:
*> A = L * Q .
*> \endverbatim
*
*> \verbatim
*> A is COMPLEX array, dimension (LDA,N)
*> On entry, the M-by-N matrix A.
-*> On exit, the elements on and below the diagonal of the array
-*> contain the M-by-min(M,N) lower trapezoidal matrix L
+*> On exit, the elements on and below the diagonal of the array
+*> contain the M-by-min(M,N) lower trapezoidal matrix L
*> (L is lower triangular if M <= N);
-*> the elements above the diagonal are the rows of
+*> the elements above the diagonal are the rows of
*> blocked V representing Q (see Further Details).
*> \endverbatim
*>
*> \verbatim
*> WORK1 is COMPLEX array, dimension (MAX(1,LWORK1))
*> WORK1 contains part of the data structure used to store Q.
-*> WORK1(1): algorithm type = 1, to indicate output from
+*> WORK1(1): algorithm type = 1, to indicate output from
*> CLASWLQ or CGELQT
*> WORK1(2): optimum size of WORK1
*> WORK1(3): minimum size of WORK1
*> WORK1(4): horizontal block size
*> WORK1(5): vertical block size
-*> WORK1(6:LWORK1): data structure needed for Q, computed by
+*> WORK1(6:LWORK1): data structure needed for Q, computed by
*> CLASWLQ or CGELQT
*> \endverbatim
*>
*> \verbatim
*> LWORK1 is INTEGER
*> The dimension of the array WORK1.
-*> If LWORK1 = -1, then a query is assumed. In this case the
+*> If LWORK1 = -1, then a query is assumed. In this case the
*> routine calculates the optimal size of WORK1 and
-*> returns this value in WORK1(2), and calculates the minimum
-*> size of WORK1 and returns this value in WORK1(3).
-*> No error message related to LWORK1 is issued by XERBLA when
+*> returns this value in WORK1(2), and calculates the minimum
+*> size of WORK1 and returns this value in WORK1(3).
+*> No error message related to LWORK1 is issued by XERBLA when
*> LWORK1 = -1.
*> \endverbatim
*>
*> \param[out] WORK2
*> \verbatim
*> (workspace) COMPLEX array, dimension (MAX(1,LWORK2))
-*>
+*>
*> \endverbatim
*> \param[in] LWORK2
*> \verbatim
*> LWORK2 is INTEGER
*> The dimension of the array WORK2.
*> If LWORK2 = -1, then a query is assumed. In this case the
-*> routine calculates the optimal size of WORK2 and
+*> routine calculates the optimal size of WORK2 and
*> returns this value in WORK2(1), and calculates the minimum
*> size of WORK2 and returns this value in WORK2(2).
*> No error message related to LWORK2 is issued by XERBLA when
*> Depending on the matrix dimensions M and N, and row and column
*> block sizes MB and NB returned by ILAENV, GELQ will use either
*> LASWLQ(if the matrix is short-and-wide) or GELQT to compute
-*> the LQ decomposition.
+*> the LQ decomposition.
*> The output of LASWLQ or GELQT representing Q is stored in A and in
-*> array WORK1(6:LWORK1) for later use.
-*> WORK1(2:5) contains the matrix dimensions M,N and block sizes MB, NB
-*> which are needed to interpret A and WORK1(6:LWORK1) for later use.
-*> WORK1(1)=1 indicates that the code needed to take WORK1(2:5) and
+*> array WORK1(6:LWORK1) for later use.
+*> WORK1(2:5) contains the matrix dimensions M,N and block sizes MB, NB
+*> which are needed to interpret A and WORK1(6:LWORK1) for later use.
+*> WORK1(1)=1 indicates that the code needed to take WORK1(2:5) and
*> decide whether LASWLQ or GELQT was used is the same as used below in
-*> GELQ. For a detailed description of A and WORK1(6:LWORK1), see
+*> GELQ. For a detailed description of A and WORK1(6:LWORK1), see
*> Further Details in LASWLQ or GELQT.
*> \endverbatim
*>
* =====================================================================
- SUBROUTINE CGELQ( M, N, A, LDA, WORK1, LWORK1, WORK2, LWORK2,
+ SUBROUTINE CGELQ( M, N, A, LDA, WORK1, LWORK1, WORK2, LWORK2,
$ INFO)
*
* -- LAPACK computational routine (version 3.5.0) --
*
LQUERY = ( LWORK1.EQ.-1 .OR. LWORK2.EQ.-1 )
*
-* Determine the block size
-*
+* Determine the block size
+*
IF ( MIN(M,N).GT.0 ) THEN
MB = ILAENV( 1, 'CGELQ ', ' ', M, N, 1, -1)
NB = ILAENV( 1, 'CGELQ ', ' ', M, N, 2, -1)
NBLCKS = 1
END IF
* Determine if the workspace size satisfies minimum size
-*
- LMINWS = .FALSE.
+*
+ LMINWS = .FALSE.
IF((LWORK1.LT.MAX(1,MB*M*NBLCKS+5)
$ .OR.(LWORK2.LT.MB*M)).AND.(LWORK2.GE.M).AND.(LWORK1.GE.M+5)
$ .AND.(.NOT.LQUERY)) THEN
IF (LWORK1.LT.MAX(1,MB*M*NBLCKS+5)) THEN
LMINWS = .TRUE.
MB = 1
- END IF
+ END IF
IF (LWORK1.LT.MAX(1,M*NBLCKS+5)) THEN
LMINWS = .TRUE.
- NB = N
+ NB = N
END IF
IF (LWORK2.LT.MB*M) THEN
LMINWS = .TRUE.
INFO = -2
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -4
- ELSE IF( LWORK1.LT.MAX( 1, MB*M*NBLCKS+5 )
+ ELSE IF( LWORK1.LT.MAX( 1, MB*M*NBLCKS+5 )
$ .AND.(.NOT.LQUERY).AND. (.NOT.LMINWS)) THEN
INFO = -6
ELSE IF( (LWORK2.LT.MAX(1,M*MB)).AND.(.NOT.LQUERY)
$ .AND.(.NOT.LMINWS) ) THEN
- INFO = -8
- END IF
+ INFO = -8
+ END IF
*
IF( INFO.EQ.0) THEN
WORK1(1) = 1
*
IF((N.LE.M).OR.(NB.LE.M).OR.(NB.GE.N)) THEN
CALL CGELQT( M, N, MB, A, LDA, WORK1(6), MB, WORK2, INFO)
- ELSE
- CALL CLASWLQ( M, N, MB, NB, A, LDA, WORK1(6), MB, WORK2,
+ ELSE
+ CALL CLASWLQ( M, N, MB, NB, A, LDA, WORK1(6), MB, WORK2,
$ LWORK2, INFO)
END IF
RETURN
-*
+*
* End of CGELQ
*
- END
\ No newline at end of file
+ END
* ===========
*
* SUBROUTINE CGELQT( M, N, MB, A, LDA, T, LDT, WORK, INFO )
-*
+*
* .. Scalar Arguments ..
* INTEGER INFO, LDA, LDT, M, N, MB
* ..
* .. Array Arguments ..
* COMPLEX A( LDA, * ), T( LDT, * ), WORK( * )
* ..
-*
+*
*
*> \par Purpose:
* =============
*> \verbatim
*>
*> CGELQT computes a blocked LQ factorization of a complex M-by-N matrix A
-*> using the compact WY representation of Q.
+*> using the compact WY representation of Q.
*> \endverbatim
*
* Arguments:
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
*> \date November 2013
*
*> V = ( 1 v1 v1 v1 v1 )
*> ( 1 v2 v2 v2 )
*> ( 1 v3 v3 )
-*>
+*>
*>
*> where the vi's represent the vectors which define H(i), which are returned
-*> in the matrix A. The 1's along the diagonal of V are not stored in A.
+*> in the matrix A. The 1's along the diagonal of V are not stored in A.
*> Let K=MIN(M,N). The number of blocks is B = ceiling(K/NB), where each
-*> block is of order NB except for the last block, which is of order
+*> block is of order NB except for the last block, which is of order
*> IB = K - (B-1)*NB. For each of the B blocks, a upper triangular block
-*> reflector factor is computed: T1, T2, ..., TB. The NB-by-NB (and IB-by-IB
+*> reflector factor is computed: T1, T2, ..., TB. The NB-by-NB (and IB-by-IB
*> for the last block) T's are stored in the NB-by-N matrix T as
*>
*> T = (T1 T2 ... TB).
*
DO I = 1, K, MB
IB = MIN( K-I+1, MB )
-*
+*
* Compute the LQ factorization of the current block A(I:M,I:I+IB-1)
-*
+*
CALL CGELQT3( IB, N-I+1, A(I,I), LDA, T(1,I), LDT, IINFO )
IF( I+IB.LE.M ) THEN
*
* Update by applying H**T to A(I:M,I+IB:N) from the right
*
CALL CLARFB( 'R', 'N', 'F', 'R', M-I-IB+1, N-I+1, IB,
- $ A( I, I ), LDA, T( 1, I ), LDT,
+ $ A( I, I ), LDA, T( 1, I ), LDT,
$ A( I+IB, I ), LDA, WORK , M-I-IB+1 )
END IF
END DO
RETURN
-*
+*
* End of CGELQT
*
END
-*
+*
* Definition:
* ===========
*
-* SUBROUTINE CGEMLQ( SIDE, TRANS, M, N, K, A, LDA, WORK1,
+* SUBROUTINE CGEMLQ( SIDE, TRANS, M, N, K, A, LDA, WORK1,
* $ LWORK1, C, LDC, WORK2, LWORK2, INFO )
*
*
* =============
*>
*> \verbatim
-*>
+*>
*> CGEMLQ overwrites the general real M-by-N matrix C with
*>
-*>
+*>
*> SIDE = 'L' SIDE = 'R'
*> TRANS = 'N': Q * C C * Q
*> TRANS = 'T': Q**T * C C * Q**T
-*> where Q is a complex orthogonal matrix defined as the product
-*> of blocked elementary reflectors computed by short wide LQ
+*> where Q is a complex orthogonal matrix defined as the product
+*> of blocked elementary reflectors computed by short wide LQ
*> factorization (DGELQ)
*> \endverbatim
*
*> The number of elementary reflectors whose product defines
*> the matrix Q.
*> M >= K >= 0;
-*>
+*>
*> \endverbatim
*>
*> \param[in,out] A
*> \param[out] WORK2
*> \verbatim
*> (workspace) COMPLEX array, dimension (MAX(1,LWORK2))
-*>
+*>
*> \endverbatim
*> \param[in] LWORK2
*> \verbatim
*> LWORK2 is INTEGER
-*> The dimension of the array WORK2.
+*> The dimension of the array WORK2.
*> If LWORK2 = -1, then a workspace query is assumed; the routine
*> only calculates the optimal size of the WORK2 array, returns
-*> this value as the third entry of the WORK2 array (WORK2(1)),
+*> this value as the third entry of the WORK2 array (WORK2(1)),
*> and no error message related to LWORK2 is issued by XERBLA.
*>
*> \endverbatim
*> Depending on the matrix dimensions M and N, and row and column
*> block sizes MB and NB returned by ILAENV, GELQ will use either
*> LASWLQ(if the matrix is short-and-wide) or GELQT to compute
-*> the LQ decomposition.
+*> the LQ decomposition.
*> The output of LASWLQ or GELQT representing Q is stored in A and in
-*> array WORK1(6:LWORK1) for later use.
-*> WORK1(2:5) contains the matrix dimensions M,N and block sizes MB, NB
-*> which are needed to interpret A and WORK1(6:LWORK1) for later use.
-*> WORK1(1)=1 indicates that the code needed to take WORK1(2:5) and
+*> array WORK1(6:LWORK1) for later use.
+*> WORK1(2:5) contains the matrix dimensions M,N and block sizes MB, NB
+*> which are needed to interpret A and WORK1(6:LWORK1) for later use.
+*> WORK1(1)=1 indicates that the code needed to take WORK1(2:5) and
*> decide whether LASWLQ or GELQT was used is the same as used below in
-*> GELQ. For a detailed description of A and WORK1(6:LWORK1), see
+*> GELQ. For a detailed description of A and WORK1(6:LWORK1), see
*> Further Details in LASWLQ or GELQT.
*> \endverbatim
*>
* =====================================================================
- SUBROUTINE CGEMLQ( SIDE, TRANS, M, N, K, A, LDA, WORK1, LWORK1,
+ SUBROUTINE CGEMLQ( SIDE, TRANS, M, N, K, A, LDA, WORK1, LWORK1,
$ C, LDC, WORK2, LWORK2, INFO )
*
* -- LAPACK computational routine (version 3.5.0) --
*
IF( MIN(M,N,K).EQ.0 ) THEN
RETURN
- END IF
+ END IF
*
IF((LEFT.AND.M.LE.K).OR.(RIGHT.AND.N.LE.K).OR.(NB.LE.K).OR.
$ (NB.GE.MAX(M,N,K))) THEN
- CALL CGEMLQT( SIDE, TRANS, M, N, K, MB, A, LDA,
- $ WORK1(6), MB, C, LDC, WORK2, INFO)
+ CALL CGEMLQT( SIDE, TRANS, M, N, K, MB, A, LDA,
+ $ WORK1(6), MB, C, LDC, WORK2, INFO)
ELSE
CALL CLAMSWLQ( SIDE, TRANS, M, N, K, MB, NB, A, LDA, WORK1(6),
$ MB, C, LDC, WORK2, LWORK2, INFO )
*
* End of CGEMLQ
*
- END
\ No newline at end of file
+ END
* Definition:
* ===========
*
-* SUBROUTINE CGEMLQT( SIDE, TRANS, M, N, K, MB, V, LDV, T, LDT,
+* SUBROUTINE CGEMLQT( SIDE, TRANS, M, N, K, MB, V, LDV, T, LDT,
* C, LDC, WORK, INFO )
-*
+*
* .. Scalar Arguments ..
* CHARACTER SIDE, TRANS
* INTEGER INFO, K, LDV, LDC, M, N, MB, LDT
* .. Array Arguments ..
* COMPLEX V( LDV, * ), C( LDC, * ), T( LDT, * ), WORK( * )
* ..
-*
+*
*
*> \par Purpose:
* =============
*>
*> Q = H(1) H(2) . . . H(K) = I - V C V**C
*>
-*> generated using the compact WY representation as returned by CGELQT.
+*> generated using the compact WY representation as returned by CGELQT.
*>
*> Q is of order M if SIDE = 'L' and of order N if SIDE = 'R'.
*> \endverbatim
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
*> \date November 2013
*
*> \ingroup doubleGEcomputational
*
* =====================================================================
- SUBROUTINE CGEMLQT( SIDE, TRANS, M, N, K, MB, V, LDV, T, LDT,
+ SUBROUTINE CGEMLQT( SIDE, TRANS, M, N, K, MB, V, LDV, T, LDT,
$ C, LDC, WORK, INFO )
*
* -- LAPACK computational routine (version 3.5.0) --
RIGHT = LSAME( SIDE, 'R' )
TRAN = LSAME( TRANS, 'C' )
NOTRAN = LSAME( TRANS, 'N' )
-*
+*
IF( LEFT ) THEN
LDWORK = MAX( 1, N )
ELSE IF ( RIGHT ) THEN
*
DO I = 1, K, MB
IB = MIN( MB, K-I+1 )
- CALL CLARFB( 'L', 'C', 'F', 'R', M-I+1, N, IB,
- $ V( I, I ), LDV, T( 1, I ), LDT,
+ CALL CLARFB( 'L', 'C', 'F', 'R', M-I+1, N, IB,
+ $ V( I, I ), LDV, T( 1, I ), LDT,
$ C( I, 1 ), LDC, WORK, LDWORK )
END DO
-*
+*
ELSE IF( RIGHT .AND. TRAN ) THEN
*
DO I = 1, K, MB
IB = MIN( MB, K-I+1 )
- CALL CLARFB( 'R', 'N', 'F', 'R', M, N-I+1, IB,
- $ V( I, I ), LDV, T( 1, I ), LDT,
+ CALL CLARFB( 'R', 'N', 'F', 'R', M, N-I+1, IB,
+ $ V( I, I ), LDV, T( 1, I ), LDT,
$ C( 1, I ), LDC, WORK, LDWORK )
END DO
*
*
KF = ((K-1)/MB)*MB+1
DO I = KF, 1, -MB
- IB = MIN( MB, K-I+1 )
- CALL CLARFB( 'L', 'N', 'F', 'R', M-I+1, N, IB,
- $ V( I, I ), LDV, T( 1, I ), LDT,
+ IB = MIN( MB, K-I+1 )
+ CALL CLARFB( 'L', 'N', 'F', 'R', M-I+1, N, IB,
+ $ V( I, I ), LDV, T( 1, I ), LDT,
$ C( I, 1 ), LDC, WORK, LDWORK )
END DO
*
*
KF = ((K-1)/MB)*MB+1
DO I = KF, 1, -MB
- IB = MIN( MB, K-I+1 )
- CALL CLARFB( 'R', 'C', 'F', 'R', M, N-I+1, IB,
- $ V( I, I ), LDV, T( 1, I ), LDT,
+ IB = MIN( MB, K-I+1 )
+ CALL CLARFB( 'R', 'C', 'F', 'R', M, N-I+1, IB,
+ $ V( I, I ), LDV, T( 1, I ), LDT,
$ C( 1, I ), LDC, WORK, LDWORK )
END DO
*
-*
+*
* Definition:
* ===========
*
-* SUBROUTINE CGEMQR( SIDE, TRANS, M, N, K, A, LDA, WORK1,
+* SUBROUTINE CGEMQR( SIDE, TRANS, M, N, K, A, LDA, WORK1,
* $ LWORK1, C, LDC, WORK2, LWORK2, INFO )
*
*
* =============
*>
*> \verbatim
-*>
+*>
*> CGEMQR overwrites the general real M-by-N matrix C with
*>
-*>
+*>
*> SIDE = 'L' SIDE = 'R'
*> TRANS = 'N': Q * C C * Q
*> TRANS = 'T': Q**T * C C * Q**T
-*> where Q is a complex orthogonal matrix defined as the product
-*> of blocked elementary reflectors computed by tall skinny
+*> where Q is a complex orthogonal matrix defined as the product
+*> of blocked elementary reflectors computed by tall skinny
*> QR factorization (CGEQR)
*> \endverbatim
*
*> The number of elementary reflectors whose product defines
*> the matrix Q.
*> N >= K >= 0;
-*>
+*>
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX array, dimension (LDA,K)
-*> The i-th column must contain the vector which defines the
-*> blockedelementary reflector H(i), for i = 1,2,...,k, as
-*> returned by DGETSQR in the first k columns of
+*> The i-th column must contain the vector which defines the
+*> blockedelementary reflector H(i), for i = 1,2,...,k, as
+*> returned by DGETSQR in the first k columns of
*> its array argument A.
*> \endverbatim
*>
*> \param[out] WORK2
*> \verbatim
*> (workspace) COMPLEX array, dimension (MAX(1,LWORK2))
-*>
+*>
*> \endverbatim
*> \param[in] LWORK2
*> \verbatim
*> LWORK2 is INTEGER
-*> The dimension of the array WORK2.
+*> The dimension of the array WORK2.
*> If LWORK2 = -1, then a workspace query is assumed; the routine
*> only calculates the optimal size of the WORK2 array, returns
-*> this value as the third entry of the WORK2 array (WORK2(1)),
+*> this value as the third entry of the WORK2 array (WORK2(1)),
*> and no error message related to LWORK2 is issued by XERBLA.
*>
*> \endverbatim
*> Depending on the matrix dimensions M and N, and row and column
*> block sizes MB and NB returned by ILAENV, GEQR will use either
*> LATSQR (if the matrix is tall-and-skinny) or GEQRT to compute
-*> the QR decomposition.
+*> the QR decomposition.
*> The output of LATSQR or GEQRT representing Q is stored in A and in
-*> array WORK1(6:LWORK1) for later use.
-*> WORK1(2:5) contains the matrix dimensions M,N and block sizes MB,NB
-*> which are needed to interpret A and WORK1(6:LWORK1) for later use.
-*> WORK1(1)=1 indicates that the code needed to take WORK1(2:5) and
-*> decide whether LATSQR or GEQRT was used is the same as used below in
+*> array WORK1(6:LWORK1) for later use.
+*> WORK1(2:5) contains the matrix dimensions M,N and block sizes MB,NB
+*> which are needed to interpret A and WORK1(6:LWORK1) for later use.
+*> WORK1(1)=1 indicates that the code needed to take WORK1(2:5) and
+*> decide whether LATSQR or GEQRT was used is the same as used below in
*> GEQR. For a detailed description of A and WORK1(6:LWORK1), see
*> Further Details in LATSQR or GEQRT.
*> \endverbatim
*>
* =====================================================================
- SUBROUTINE CGEMQR( SIDE, TRANS, M, N, K, A, LDA, WORK1, LWORK1,
+ SUBROUTINE CGEMQR( SIDE, TRANS, M, N, K, A, LDA, WORK1, LWORK1,
$ C, LDC, WORK2, LWORK2, INFO )
*
* -- LAPACK computational routine (version 3.5.0) --
LOGICAL LSAME
EXTERNAL LSAME
* .. External Subroutines ..
- EXTERNAL CGEMQRT, CLAMTSQR, XERBLA
+ EXTERNAL CGEMQRT, CLAMTSQR, XERBLA
* .. Intrinsic Functions ..
INTRINSIC INT, MAX, MIN, MOD
* ..
ELSE IF(RIGHT) THEN
LW = MB * NB
MN = N
- END IF
+ END IF
*
IF ((MB.GT.K).AND.(MN.GT.K)) THEN
IF(MOD(MN-K, MB-K).EQ.0) THEN
END IF
*
* Determine the block size if it is tall skinny or short and wide
-*
+*
IF( INFO.EQ.0) THEN
WORK2(1) = LW
END IF
*
IF((LEFT.AND.M.LE.K).OR.(RIGHT.AND.N.LE.K).OR.(MB.LE.K).OR.
$ (MB.GE.MAX(M,N,K))) THEN
- CALL CGEMQRT( SIDE, TRANS, M, N, K, NB, A, LDA,
- $ WORK1(6), NB, C, LDC, WORK2, INFO)
+ CALL CGEMQRT( SIDE, TRANS, M, N, K, NB, A, LDA,
+ $ WORK1(6), NB, C, LDC, WORK2, INFO)
ELSE
CALL CLAMTSQR( SIDE, TRANS, M, N, K, MB, NB, A, LDA, WORK1(6),
$ NB, C, LDC, WORK2, LWORK2, INFO )
- END IF
+ END IF
*
WORK2(1) = LW
RETURN
*
* End of CGEMQR
*
- END
\ No newline at end of file
+ END
-*
+*
* Definition:
* ===========
*
* SUBROUTINE CGEQR( M, N, A, LDA, WORK1, LWORK1, WORK2, LWORK2,
* INFO)
-*
+*
* .. Scalar Arguments ..
* INTEGER INFO, LDA, M, N, LWORK1, LWORK2
* ..
* .. Array Arguments ..
* COMPLEX A( LDA, * ), WORK1( * ), WORK2( * )
* ..
-*
+*
*
*> \par Purpose:
* =============
*>
*> \verbatim
-*>
-*> CGEQR computes a QR factorization of an M-by-N matrix A,
-*> using CLATSQR when A is tall and skinny
-*> (M sufficiently greater than N), and otherwise CGEQRT:
+*>
+*> CGEQR computes a QR factorization of an M-by-N matrix A,
+*> using CLATSQR when A is tall and skinny
+*> (M sufficiently greater than N), and otherwise CGEQRT:
*> A = Q * R .
*> \endverbatim
*
*> A is COMPLEX array, dimension (LDA,N)
*> On entry, the M-by-N matrix A.
*> On exit, the elements on and above the diagonal of the array
-*> contain the min(M,N)-by-N upper trapezoidal matrix R
+*> contain the min(M,N)-by-N upper trapezoidal matrix R
*> (R is upper triangular if M >= N);
*> the elements below the diagonal represent Q (see Further Details).
*> \endverbatim
*> \verbatim
*> WORK1 is COMPLEX array, dimension (MAX(1,LWORK1))
*> WORK1 contains part of the data structure used to store Q.
-*> WORK1(1): algorithm type = 1, to indicate output from
+*> WORK1(1): algorithm type = 1, to indicate output from
*> CLATSQR or CGEQRT
*> WORK1(2): optimum size of WORK1
*> WORK1(3): minimum size of WORK1
*> WORK1(4): row block size
*> WORK1(5): column block size
-*> WORK1(6:LWORK1): data structure needed for Q, computed by
+*> WORK1(6:LWORK1): data structure needed for Q, computed by
*> CLATSQR or CGEQRT
*> \endverbatim
*>
*> \verbatim
*> LWORK1 is INTEGER
*> The dimension of the array WORK1.
-*> If LWORK1 = -1, then a query is assumed. In this case the
+*> If LWORK1 = -1, then a query is assumed. In this case the
*> routine calculates the optimal size of WORK1 and
-*> returns this value in WORK1(2), and calculates the minimum
-*> size of WORK1 and returns this value in WORK1(3).
-*> No error message related to LWORK1 is issued by XERBLA when
+*> returns this value in WORK1(2), and calculates the minimum
+*> size of WORK1 and returns this value in WORK1(3).
+*> No error message related to LWORK1 is issued by XERBLA when
*> LWORK1 = -1.
*> \endverbatim
*>
*> \param[out] WORK2
*> \verbatim
-*> (workspace) COMPLEX array, dimension (MAX(1,LWORK2))
+*> (workspace) COMPLEX array, dimension (MAX(1,LWORK2))
*> \endverbatim
*>
*> \param[in] LWORK2
*> \verbatim
*> LWORK2 is INTEGER
*> The dimension of the array WORK2.
-*> If LWORK2 = -1, then a query is assumed. In this case the
-*> routine calculates the optimal size of WORK2 and
+*> If LWORK2 = -1, then a query is assumed. In this case the
+*> routine calculates the optimal size of WORK2 and
*> returns this value in WORK2(1), and calculates the minimum
*> size of WORK2 and returns this value in WORK2(2).
*> No error message related to LWORK2 is issued by XERBLA when
*> Depending on the matrix dimensions M and N, and row and column
*> block sizes MB and NB returned by ILAENV, GEQR will use either
*> LATSQR (if the matrix is tall-and-skinny) or GEQRT to compute
-*> the QR decomposition.
+*> the QR decomposition.
*> The output of LATSQR or GEQRT representing Q is stored in A and in
-*> array WORK1(6:LWORK1) for later use.
-*> WORK1(2:5) contains the matrix dimensions M,N and block sizes MB,NB
-*> which are needed to interpret A and WORK1(6:LWORK1) for later use.
-*> WORK1(1)=1 indicates that the code needed to take WORK1(2:5) and
-*> decide whether LATSQR or GEQRT was used is the same as used below in
+*> array WORK1(6:LWORK1) for later use.
+*> WORK1(2:5) contains the matrix dimensions M,N and block sizes MB,NB
+*> which are needed to interpret A and WORK1(6:LWORK1) for later use.
+*> WORK1(1)=1 indicates that the code needed to take WORK1(2:5) and
+*> decide whether LATSQR or GEQRT was used is the same as used below in
*> GEQR. For a detailed description of A and WORK1(6:LWORK1), see
*> Further Details in LATSQR or GEQRT.
*> \endverbatim
*>
* =====================================================================
- SUBROUTINE CGEQR( M, N, A, LDA, WORK1, LWORK1, WORK2, LWORK2,
+ SUBROUTINE CGEQR( M, N, A, LDA, WORK1, LWORK1, WORK2, LWORK2,
$ INFO)
*
* -- LAPACK computational routine (version 3.5.0) --
*
LQUERY = ( LWORK1.EQ.-1 .OR. LWORK2.EQ.-1 )
*
-* Determine the block size
-*
+* Determine the block size
+*
IF ( MIN(M,N).GT.0 ) THEN
MB = ILAENV( 1, 'CGEQR ', ' ', M, N, 1, -1)
NB = ILAENV( 1, 'CGEQR ', ' ', M, N, 2, -1)
END IF
*
* Determine if the workspace size satisfies minimum size
-*
+*
LMINWS = .FALSE.
- IF((LWORK1.LT.MAX(1, NB*N*NBLCKS+5)
- $ .OR.(LWORK2.LT.NB*N)).AND.(LWORK2.GE.N).AND.(LWORK1.GT.N+5)
+ IF((LWORK1.LT.MAX(1, NB*N*NBLCKS+5)
+ $ .OR.(LWORK2.LT.NB*N)).AND.(LWORK2.GE.N).AND.(LWORK1.GT.N+5)
$ .AND.(.NOT.LQUERY)) THEN
IF (LWORK1.LT.MAX(1, NB * N * NBLCKS+5)) THEN
LMINWS = .TRUE.
NB = 1
- END IF
+ END IF
IF (LWORK1.LT.MAX(1, N * NBLCKS+5)) THEN
LMINWS = .TRUE.
- MB = M
+ MB = M
END IF
IF (LWORK2.LT.NB*N) THEN
LMINWS = .TRUE.
INFO = -2
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -4
- ELSE IF( LWORK1.LT.MAX( 1, NB * N * NBLCKS + 5 )
+ ELSE IF( LWORK1.LT.MAX( 1, NB * N * NBLCKS + 5 )
$ .AND.(.NOT.LQUERY).AND.(.NOT.LMINWS)) THEN
INFO = -6
- ELSE IF( (LWORK2.LT.MAX(1,N*NB)).AND.(.NOT.LQUERY)
+ ELSE IF( (LWORK2.LT.MAX(1,N*NB)).AND.(.NOT.LQUERY)
$ .AND.(.NOT.LMINWS)) THEN
- INFO = -8
- END IF
+ INFO = -8
+ END IF
*
IF( INFO.EQ.0) THEN
WORK1(1) = 1
IF((M.LE.N).OR.(MB.LE.N).OR.(MB.GE.M)) THEN
CALL CGEQRT( M, N, NB, A, LDA, WORK1(6), NB, WORK2, INFO)
RETURN
- ELSE
- CALL CLATSQR( M, N, MB, NB, A, LDA, WORK1(6), NB, WORK2,
+ ELSE
+ CALL CLATSQR( M, N, MB, NB, A, LDA, WORK1(6), NB, WORK2,
$ LWORK2, INFO)
END IF
RETURN
-*
+*
* End of CGEQR
*
- END
\ No newline at end of file
+ END
*
* End of CGETSLS
*
- END
\ No newline at end of file
+ END
*> indicating the nonzero elements in Z. The i-th eigenvector
*> is nonzero only in elements ISUPPZ( 2*i-1 ) through
*> ISUPPZ( 2*i ). This is an output of CSTEMR (tridiagonal
-*> matrix). The support of the eigenvectors of A is typically
+*> matrix). The support of the eigenvectors of A is typically
*> 1:N because of the unitary transformations applied by CUNMTR.
*> Implemented only for RANGE = 'A' or 'I' and IU - IL = N - 1
*> \endverbatim
*
* =========== DOCUMENTATION ===========
*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
-*> Download CHESV_AASEN + dependencies
-*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/chesv_aasen.f">
-*> [TGZ]</a>
-*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/chesv_aasen.f">
-*> [ZIP]</a>
-*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/chesv_aasen.f">
+*> Download CHESV_AASEN + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/chesv_aasen.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/chesv_aasen.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/chesv_aasen.f">
*> [TXT]</a>
-*> \endhtmlonly
+*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE CHESV_AASEN( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK,
* LWORK, INFO )
-*
+*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER INFO, LDA, LDB, LWORK, N, NRHS
* INTEGER IPIV( * )
* COMPLEX A( LDA, * ), B( LDB, * ), WORK( * )
* ..
-*
+*
*
*> \par Purpose:
* =============
*> A = U * T * U**H, if UPLO = 'U', or
*> A = L * T * L**H, if UPLO = 'L',
*> where U (or L) is a product of permutation and unit upper (lower)
-*> triangular matrices, and T is Hermitian and tridiagonal. The factored form
+*> triangular matrices, and T is Hermitian and tridiagonal. The factored form
*> of A is then used to solve the system of equations A * X = B.
*> \endverbatim
*
*> \param[out] IPIV
*> \verbatim
*> IPIV is INTEGER array, dimension (N)
-*> On exit, it contains the details of the interchanges, i.e.,
-*> the row and column k of A were interchanged with the
+*> On exit, it contains the details of the interchanges, i.e.,
+*> the row and column k of A were interchanged with the
*> row and column IPIV(k).
*> \endverbatim
*>
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
*> \date November 2016
*
*
* =========== DOCUMENTATION ===========
*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
-*> Download CHETRF_AASEN + dependencies
-*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/chetrf_aasen.f">
-*> [TGZ]</a>
-*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/chetrf_aasen.f">
-*> [ZIP]</a>
-*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/chetrf_aasen.f">
+*> Download CHETRF_AASEN + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/chetrf_aasen.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/chetrf_aasen.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/chetrf_aasen.f">
*> [TXT]</a>
-*> \endhtmlonly
+*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE CHETRF_AASEN( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )
-*
+*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER N, LDA, LWORK, INFO
*> triangular part of A is not referenced.
*>
*> On exit, the tridiagonal matrix is stored in the diagonals
-*> and the subdiagonals of A just below (or above) the diagonals,
+*> and the subdiagonals of A just below (or above) the diagonals,
*> and L is stored below (or above) the subdiaonals, when UPLO
*> is 'L' (or 'U').
*> \endverbatim
*> \param[out] IPIV
*> \verbatim
*> IPIV is INTEGER array, dimension (N)
-*> On exit, it contains the details of the interchanges, i.e.,
-*> the row and column k of A were interchanged with the
+*> On exit, it contains the details of the interchanges, i.e.,
+*> the row and column k of A were interchanged with the
*> row and column IPIV(k).
*> \endverbatim
*>
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
*> \date November 2016
*
*
J = 0
10 CONTINUE
- IF( J.GE.N )
+ IF( J.GE.N )
$ GO TO 20
*
* each step of the main loop
* J is the last column of the previous panel
* J1 is the first column of the current panel
* K1 identifies if the previous column of the panel has been
-* explicitly stored, e.g., K1=1 for the first panel, and
+* explicitly stored, e.g., K1=1 for the first panel, and
* K1=0 for the rest
*
J1 = J + 1
*
* Panel factorization
*
- CALL CLAHEF_AASEN( UPLO, 2-K1, N-J, JB,
+ CALL CLAHEF_AASEN( UPLO, 2-K1, N-J, JB,
$ A( MAX(1, J), J+1 ), LDA,
- $ IPIV( J+1 ), WORK, N, WORK( N*NB+1 ),
+ $ IPIV( J+1 ), WORK, N, WORK( N*NB+1 ),
$ IINFO )
IF( (IINFO.GT.0) .AND. (INFO.EQ.0) ) THEN
INFO = IINFO+J
- ENDIF
+ ENDIF
*
* Ajust IPIV and apply it back (J-th step picks (J+1)-th pivot)
*
DO J2 = J+2, MIN(N, J+JB+1)
IPIV( J2 ) = IPIV( J2 ) + J
IF( (J2.NE.IPIV(J2)) .AND. ((J1-K1).GT.2) ) THEN
- CALL CSWAP( J1-K1-2, A( 1, J2 ), 1,
+ CALL CSWAP( J1-K1-2, A( 1, J2 ), 1,
$ A( 1, IPIV(J2) ), 1 )
END IF
END DO
J = J + JB
*
* Trailing submatrix update, where
-* the row A(J1-1, J2-1:N) stores U(J1, J2+1:N) and
+* the row A(J1-1, J2-1:N) stores U(J1, J2+1:N) and
* WORK stores the current block of the auxiriarly matrix H
*
IF( J.LT.N ) THEN
*
K2 = 0
*
-* First update skips the first column
+* First update skips the first column
*
JB = JB - 1
END IF
*
* Update off-diagonal block of J2-th block row with CGEMM
*
- CALL CGEMM( 'Conjugate transpose', 'Transpose',
+ CALL CGEMM( 'Conjugate transpose', 'Transpose',
$ NJ, N-J3+1, JB+1,
$ -ONE, A( J1-K2, J2 ), LDA,
$ WORK( (J3-J1+1)+K1*N ), N,
* Factorize A as L*D*L**T using the lower triangle of A
* .....................................................
*
-* copy first column A(1:N, 1) into H(1:N, 1)
+* copy first column A(1:N, 1) into H(1:N, 1)
* (stored in WORK(1:N))
*
CALL CCOPY( N, A( 1, 1 ), 1, WORK( 1 ), 1 )
*
J = 0
11 CONTINUE
- IF( J.GE.N )
+ IF( J.GE.N )
$ GO TO 20
*
* each step of the main loop
* J is the last column of the previous panel
* J1 is the first column of the current panel
* K1 identifies if the previous column of the panel has been
-* explicitly stored, e.g., K1=1 for the first panel, and
+* explicitly stored, e.g., K1=1 for the first panel, and
* K1=0 for the rest
*
J1 = J+1
*
* Panel factorization
*
- CALL CLAHEF_AASEN( UPLO, 2-K1, N-J, JB,
+ CALL CLAHEF_AASEN( UPLO, 2-K1, N-J, JB,
$ A( J+1, MAX(1, J) ), LDA,
$ IPIV( J+1 ), WORK, N, WORK( N*NB+1 ), IINFO)
IF( (IINFO.GT.0) .AND. (INFO.EQ.0) ) THEN
INFO = IINFO+J
- ENDIF
+ ENDIF
*
* Ajust IPIV and apply it back (J-th step picks (J+1)-th pivot)
*
DO J2 = J+2, MIN(N, J+JB+1)
IPIV( J2 ) = IPIV( J2 ) + J
IF( (J2.NE.IPIV(J2)) .AND. ((J1-K1).GT.2) ) THEN
- CALL CSWAP( J1-K1-2, A( J2, 1 ), LDA,
+ CALL CSWAP( J1-K1-2, A( J2, 1 ), LDA,
$ A( IPIV(J2), 1 ), LDA )
END IF
END DO
J = J + JB
*
* Trailing submatrix update, where
-* A(J2+1, J1-1) stores L(J2+1, J1) and
+* A(J2+1, J1-1) stores L(J2+1, J1) and
* WORK(J2+1, 1) stores H(J2+1, 1)
*
IF( J.LT.N ) THEN
*
K2 = 0
*
-* First update skips the first column
+* First update skips the first column
*
JB = JB - 1
END IF
*
* Update off-diagonal block of J2-th block column with CGEMM
*
- CALL CGEMM( 'No transpose', 'Conjugate transpose',
+ CALL CGEMM( 'No transpose', 'Conjugate transpose',
$ N-J3+1, NJ, JB+1,
$ -ONE, WORK( (J3-J1+1)+K1*N ), N,
$ A( J2, J1-K2 ), LDA,
*
* =========== DOCUMENTATION ===========
*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download CHETRS_AASEN + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/chetrs_aasen.f">
-*> [TGZ]</a>
+*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/chetrs_aasen.f">
-*> [ZIP]</a>
+*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/chetrs_aasen.f">
*> [TXT]</a>
-*> \endhtmlonly
+*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE CHETRS_AASEN( UPLO, N, NRHS, A, LDA, IPIV, B, LDB,
* WORK, LWORK, INFO )
-*
+*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER N, NRHS, LDA, LDB, LWORK, INFO
* INTEGER IPIV( * )
* COMPLEX A( LDA, * ), B( LDB, * ), WORK( * )
* ..
-*
+*
*
*> \par Purpose:
* =============
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
*> \date November 2016
*
*
* Compute (L \P**T * B) -> B [ (L \P**T * B) ]
*
- CALL CTRSM( 'L', 'L', 'N', 'U', N-1, NRHS, ONE, A( 2, 1), LDA,
+ CALL CTRSM( 'L', 'L', 'N', 'U', N-1, NRHS, ONE, A( 2, 1), LDA,
$ B(2, 1), LDB)
*
* Compute T \ B -> B [ T \ (L \P**T * B) ]
$ INFO)
*
* Compute (L**T \ B) -> B [ L**T \ (T \ (L \P**T * B) ) ]
-*
+*
CALL CTRSM( 'L', 'L', 'C', 'U', N-1, NRHS, ONE, A( 2, 1 ), LDA,
$ B( 2, 1 ), LDB)
*
*
* =========== DOCUMENTATION ===========
*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
-*> Download CLAHEF_AASEN + dependencies
-*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/clahef_aasen.f">
-*> [TGZ]</a>
-*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/clahef_aasen.f">
-*> [ZIP]</a>
-*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/clahef_aasen.f">
+*> Download CLAHEF_AASEN + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/clahef_aasen.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/clahef_aasen.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/clahef_aasen.f">
*> [TXT]</a>
-*> \endhtmlonly
+*> \endhtmlonly
*
* Definition:
* ===========
*
-* SUBROUTINE CLAHEF_AASEN( UPLO, J1, M, NB, A, LDA, IPIV,
+* SUBROUTINE CLAHEF_AASEN( UPLO, J1, M, NB, A, LDA, IPIV,
* H, LDH, WORK, INFO )
-*
+*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER J1, M, NB, LDA, LDH, INFO
* INTEGER IPIV( * )
* COMPLEX A( LDA, * ), H( LDH, * ), WORK( * )
* ..
-*
+*
*
*> \par Purpose:
* =============
*> last row, or column, of the previous panel. The first row, or column,
*> of A is set to be the first row, or column, of an identity matrix,
*> which is used to factorize the first panel.
-*>
+*>
*> The resulting J-th row of U, or J-th column of L, is stored in the
-*> (J-1)-th row, or column, of A (without the unit diatonals), while
+*> (J-1)-th row, or column, of A (without the unit diatonals), while
*> the diagonal and subdiagonal of A are overwritten by those of T.
*>
*> \endverbatim
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
*> \date November 2016
*
* @generated from zlahef_aasen.f, fortran z -> c, Sun Oct 2 22:41:33 2016
*
* =====================================================================
- SUBROUTINE CLAHEF_AASEN( UPLO, J1, M, NB, A, LDA, IPIV,
+ SUBROUTINE CLAHEF_AASEN( UPLO, J1, M, NB, A, LDA, IPIV,
$ H, LDH, WORK, INFO )
*
* -- LAPACK computational routine (version 3.4.0) --
*
* .. Local Scalars ..
INTEGER J, K, K1, I1, I2
- COMPLEX PIV, ALPHA
+ COMPLEX PIV, ALPHA
* ..
* .. External Functions ..
LOGICAL LSAME
*
A( K, J ) = REAL( WORK( 1 ) )
*
- IF( J.LT.M ) THEN
+ IF( J.LT.M ) THEN
*
* Compute WORK(2:N) = T(J, J) L(J, (J+1):N)
* where A(J, J) stores T(J, J) and A(J-1, (J+1):N) stores U(J, (J+1):N)
*
IF( (J1+J-1).GT.1 ) THEN
- ALPHA = -A( K, J )
- CALL CAXPY( M-J, ALPHA, A( K-1, J+1 ), LDA,
+ ALPHA = -A( K, J )
+ CALL CAXPY( M-J, ALPHA, A( K-1, J+1 ), LDA,
$ WORK( 2 ), 1 )
ENDIF
*
*
I1 = I1+J-1
I2 = I2+J-1
- CALL CSWAP( I2-I1-1, A( J1+I1-1, I1+1 ), LDA,
+ CALL CSWAP( I2-I1-1, A( J1+I1-1, I1+1 ), LDA,
$ A( J1+I1, I2 ), 1 )
CALL CLACGV( I2-I1, A( J1+I1-1, I1+1 ), LDA )
CALL CLACGV( I2-I1-1, A( J1+I1, I2 ), 1 )
*
* Swap A(I1, I2+1:N) with A(I2, I2+1:N)
*
- CALL CSWAP( M-I2, A( J1+I1-1, I2+1 ), LDA,
+ CALL CSWAP( M-I2, A( J1+I1-1, I2+1 ), LDA,
$ A( J1+I2-1, I2+1 ), LDA )
*
* Swap A(I1, I1) with A(I2,I2)
* Swap L(1:I1-1, I1) with L(1:I1-1, I2),
* skipping the first column
*
- CALL CSWAP( I1-K1+1, A( 1, I1 ), 1,
+ CALL CSWAP( I1-K1+1, A( 1, I1 ), 1,
$ A( 1, I2 ), 1 )
END IF
- ELSE
+ ELSE
IPIV( J+1 ) = J+1
ENDIF
*
* Set A(J, J+1) = T(J, J+1)
*
A( K, J+1 ) = WORK( 2 )
- IF( (A( K, J ).EQ.ZERO ) .AND.
+ IF( (A( K, J ).EQ.ZERO ) .AND.
$ ( (J.EQ.M) .OR. (A( K, J+1 ).EQ.ZERO))) THEN
IF(INFO .EQ. 0) THEN
INFO = J
*
IF( J.LT.NB ) THEN
*
-* Copy A(J+1:N, J+1) into H(J:N, J),
+* Copy A(J+1:N, J+1) into H(J:N, J),
*
- CALL CCOPY( M-J, A( K+1, J+1 ), LDA,
+ CALL CCOPY( M-J, A( K+1, J+1 ), LDA,
$ H( J+1, J+1 ), 1 )
END IF
*
CALL CCOPY( M-J-1, WORK( 3 ), 1, A( K, J+2 ), LDA )
CALL CSCAL( M-J-1, ALPHA, A( K, J+2 ), LDA )
ELSE
- CALL CLASET( 'Full', 1, M-J-1, ZERO, ZERO,
+ CALL CLASET( 'Full', 1, M-J-1, ZERO, ZERO,
$ A( K, J+2 ), LDA)
END IF
ELSE
*
A( J, K ) = REAL( WORK( 1 ) )
*
- IF( J.LT.M ) THEN
+ IF( J.LT.M ) THEN
*
* Compute WORK(2:N) = T(J, J) L((J+1):N, J)
* where A(J, J) = T(J, J) and A((J+1):N, J-1) = L((J+1):N, J)
*
IF( (J1+J-1).GT.1 ) THEN
ALPHA = -A( J, K )
- CALL CAXPY( M-J, ALPHA, A( J+1, K-1 ), 1,
+ CALL CAXPY( M-J, ALPHA, A( J+1, K-1 ), 1,
$ WORK( 2 ), 1 )
ENDIF
*
*
I1 = I1+J-1
I2 = I2+J-1
- CALL CSWAP( I2-I1-1, A( I1+1, J1+I1-1 ), 1,
+ CALL CSWAP( I2-I1-1, A( I1+1, J1+I1-1 ), 1,
$ A( I2, J1+I1 ), LDA )
CALL CLACGV( I2-I1, A( I1+1, J1+I1-1 ), 1 )
CALL CLACGV( I2-I1-1, A( I2, J1+I1 ), LDA )
*
* Swap A(I2+1:N, I1) with A(I2+1:N, I2)
*
- CALL CSWAP( M-I2, A( I2+1, J1+I1-1 ), 1,
+ CALL CSWAP( M-I2, A( I2+1, J1+I1-1 ), 1,
$ A( I2+1, J1+I2-1 ), 1 )
*
* Swap A(I1, I1) with A(I2, I2)
* Swap L(1:I1-1, I1) with L(1:I1-1, I2),
* skipping the first column
*
- CALL CSWAP( I1-K1+1, A( I1, 1 ), LDA,
+ CALL CSWAP( I1-K1+1, A( I1, 1 ), LDA,
$ A( I2, 1 ), LDA )
END IF
- ELSE
+ ELSE
IPIV( J+1 ) = J+1
ENDIF
*
* Set A(J+1, J) = T(J+1, J)
*
A( J+1, K ) = WORK( 2 )
- IF( (A( J, K ).EQ.ZERO) .AND.
+ IF( (A( J, K ).EQ.ZERO) .AND.
$ ( (J.EQ.M) .OR. (A( J+1, K ).EQ.ZERO)) ) THEN
- IF (INFO .EQ. 0)
+ IF (INFO .EQ. 0)
$ INFO = J
END IF
*
IF( J.LT.NB ) THEN
*
-* Copy A(J+1:N, J+1) into H(J+1:N, J),
+* Copy A(J+1:N, J+1) into H(J+1:N, J),
*
- CALL CCOPY( M-J, A( J+1, K+1 ), 1,
+ CALL CCOPY( M-J, A( J+1, K+1 ), 1,
$ H( J+1, J+1 ), 1 )
END IF
*
CALL CCOPY( M-J-1, WORK( 3 ), 1, A( J+2, K ), 1 )
CALL CSCAL( M-J-1, ALPHA, A( J+2, K ), 1 )
ELSE
- CALL CLASET( 'Full', M-J-1, 1, ZERO, ZERO,
+ CALL CLASET( 'Full', M-J-1, 1, ZERO, ZERO,
$ A( J+2, K ), LDA )
END IF
ELSE
- IF( (A( J, K ).EQ.ZERO) .AND. (J.EQ.M)
+ IF( (A( J, K ).EQ.ZERO) .AND. (J.EQ.M)
$ .AND. (INFO.EQ.0) ) INFO = J
END IF
J = J + 1
-*
+*
* Definition:
* ===========
*
-* SUBROUTINE CLAMSWLQ( SIDE, TRANS, M, N, K, MB, NB, A, LDA, T,
+* SUBROUTINE CLAMSWLQ( SIDE, TRANS, M, N, K, MB, NB, A, LDA, T,
* $ LDT, C, LDC, WORK, LWORK, INFO )
*
*
* =============
*>
*> \verbatim
-*>
+*>
*> CLAMQRTS overwrites the general real M-by-N matrix C with
*>
-*>
+*>
*> SIDE = 'L' SIDE = 'R'
*> TRANS = 'N': Q * C C * Q
*> TRANS = 'T': Q**T * C C * Q**T
*> where Q is a real orthogonal matrix defined as the product of blocked
-*> elementary reflectors computed by short wide LQ
+*> elementary reflectors computed by short wide LQ
*> factorization (CLASWLQ)
*> \endverbatim
*
*> The number of elementary reflectors whose product defines
*> the matrix Q.
*> M >= K >= 0;
-*>
+*>
*> \endverbatim
*> \param[in] MB
*> \verbatim
*> MB is INTEGER
-*> The row block size to be used in the blocked QR.
-*> M >= MB >= 1
+*> The row block size to be used in the blocked QR.
+*> M >= MB >= 1
*> \endverbatim
*>
*> \param[in] NB
*> \verbatim
*> NB is INTEGER
-*> The column block size to be used in the blocked QR.
+*> The column block size to be used in the blocked QR.
*> NB > M.
*> \endverbatim
*>
*> \param[in] NB
*> \verbatim
*> NB is INTEGER
-*> The block size to be used in the blocked QR.
+*> The block size to be used in the blocked QR.
*> MB > M.
-*>
+*>
*> \endverbatim
*>
*> \param[in,out] A
*>
*> \param[in] T
*> \verbatim
-*> T is COMPLEX array, dimension
+*> T is COMPLEX array, dimension
*> ( M * Number of blocks(CEIL(N-K/NB-K)),
*> The blocked upper triangular block reflectors stored in compact form
*> as a sequence of upper triangular blocks. See below
*> \param[out] WORK
*> \verbatim
*> (workspace) COMPLEX array, dimension (MAX(1,LWORK))
-*>
+*>
*> \endverbatim
*> \param[in] LWORK
*> \verbatim
*> block reflectors, stored in array T(1:LDT,(i-1)*M+1:i*M).
*> The last Q(k) may use fewer rows.
*> For more information see Further Details in TPQRT.
-*>
+*>
*> For more details of the overall algorithm, see the description of
*> Sequential TSQR in Section 2.2 of [1].
*>
*> \endverbatim
*>
* =====================================================================
- SUBROUTINE CLAMSWLQ( SIDE, TRANS, M, N, K, MB, NB, A, LDA, T,
+ SUBROUTINE CLAMSWLQ( SIDE, TRANS, M, N, K, MB, NB, A, LDA, T,
$ LDT, C, LDC, WORK, LWORK, INFO )
*
* -- LAPACK computational routine (version 3.5.0) --
*
IF( MIN(M,N,K).EQ.0 ) THEN
RETURN
- END IF
+ END IF
*
IF((NB.LE.K).OR.(NB.GE.MAX(M,N,K))) THEN
- CALL CGEMLQT( SIDE, TRANS, M, N, K, MB, A, LDA,
- $ T, LDT, C, LDC, WORK, INFO)
+ CALL CGEMLQT( SIDE, TRANS, M, N, K, MB, A, LDA,
+ $ T, LDT, C, LDC, WORK, INFO)
RETURN
END IF
*
IF(II.LE.N) THEN
*
* Multiply Q to the last block of C
-*
+*
CALL CTPMLQT('R','C',M , KK, K, 0,MB, A(1,II), LDA,
$ T(1,CTR*K+1),LDT, C(1,1), LDC,
$ C(1,II), LDC, WORK, INFO )
*
* End of CLAMSWLQ
*
- END
\ No newline at end of file
+ END
-*
+*
* Definition:
* ===========
*
-* SUBROUTINE CLAMTSQR( SIDE, TRANS, M, N, K, MB, NB, A, LDA, T,
+* SUBROUTINE CLAMTSQR( SIDE, TRANS, M, N, K, MB, NB, A, LDA, T,
* $ LDT, C, LDC, WORK, LWORK, INFO )
*
*
* =============
*>
*> \verbatim
-*>
+*>
*> CLAMTSQR overwrites the general complex M-by-N matrix C with
*>
-*>
+*>
*> SIDE = 'L' SIDE = 'R'
*> TRANS = 'N': Q * C C * Q
*> TRANS = 'C': Q**C * C C * Q**C
-*> where Q is a real orthogonal matrix defined as the product
-*> of blocked elementary reflectors computed by tall skinny
+*> where Q is a real orthogonal matrix defined as the product
+*> of blocked elementary reflectors computed by tall skinny
*> QR factorization (CLATSQR)
*> \endverbatim
*
*> The number of elementary reflectors whose product defines
*> the matrix Q.
*> N >= K >= 0;
-*>
+*>
*> \endverbatim
*>
*> \param[in] MB
*> \verbatim
*> MB is INTEGER
-*> The block size to be used in the blocked QR.
+*> The block size to be used in the blocked QR.
*> MB > N. (must be the same as DLATSQR)
*> \endverbatim
*>
*> \param[in] NB
*> \verbatim
*> NB is INTEGER
-*> The column block size to be used in the blocked QR.
+*> The column block size to be used in the blocked QR.
*> N >= NB >= 1.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX array, dimension (LDA,K)
-*> The i-th column must contain the vector which defines the
-*> blockedelementary reflector H(i), for i = 1,2,...,k, as
-*> returned by DLATSQR in the first k columns of
+*> The i-th column must contain the vector which defines the
+*> blockedelementary reflector H(i), for i = 1,2,...,k, as
+*> returned by DLATSQR in the first k columns of
*> its array argument A.
*> \endverbatim
*>
*>
*> \param[in] T
*> \verbatim
-*> T is COMPLEX array, dimension
+*> T is COMPLEX array, dimension
*> ( N * Number of blocks(CEIL(M-K/MB-K)),
*> The blocked upper triangular block reflectors stored in compact form
*> as a sequence of upper triangular blocks. See below
*> \param[out] WORK
*> \verbatim
*> (workspace) COMPLEX array, dimension (MAX(1,LWORK))
-*>
+*>
*> \endverbatim
*> \param[in] LWORK
*> \verbatim
*> LWORK is INTEGER
*> The dimension of the array WORK.
-*>
+*>
*> If SIDE = 'L', LWORK >= max(1,N)*NB;
*> if SIDE = 'R', LWORK >= max(1,MB)*NB.
*> If LWORK = -1, then a workspace query is assumed; the routine
*> block reflectors, stored in array T(1:LDT,(i-1)*N+1:i*N).
*> The last Q(k) may use fewer rows.
*> For more information see Further Details in TPQRT.
-*>
+*>
*> For more details of the overall algorithm, see the description of
*> Sequential TSQR in Section 2.2 of [1].
*>
*> \endverbatim
*>
* =====================================================================
- SUBROUTINE CLAMTSQR( SIDE, TRANS, M, N, K, MB, NB, A, LDA, T,
+ SUBROUTINE CLAMTSQR( SIDE, TRANS, M, N, K, MB, NB, A, LDA, T,
$ LDT, C, LDC, WORK, LWORK, INFO )
*
* -- LAPACK computational routine (version 3.5.0) --
LOGICAL LSAME
EXTERNAL LSAME
* .. External Subroutines ..
- EXTERNAL CGEMQRT, CTPMQRT, XERBLA
+ EXTERNAL CGEMQRT, CTPMQRT, XERBLA
* ..
* .. Executable Statements ..
*
IF( INFO.EQ.0) THEN
*
* Determine the block size if it is tall skinny or short and wide
-*
+*
IF( INFO.EQ.0) THEN
- WORK(1) = LW
+ WORK(1) = LW
END IF
END IF
IF( INFO.NE.0 ) THEN
END IF
*
IF((MB.LE.K).OR.(MB.GE.MAX(M,N,K))) THEN
- CALL CGEMQRT( SIDE, TRANS, M, N, K, NB, A, LDA,
- $ T, LDT, C, LDC, WORK, INFO)
+ CALL CGEMQRT( SIDE, TRANS, M, N, K, NB, A, LDA,
+ $ T, LDT, C, LDC, WORK, INFO)
RETURN
- END IF
+ END IF
*
IF(LEFT.AND.NOTRAN) THEN
*
IF(II.LE.M) THEN
*
* Multiply Q to the last block of C
-*
+*
CALL CTPMQRT('L','C',KK , N, K, 0,NB, A(II,1), LDA,
$ T(1,CTR*K+1), LDT, C(1,1), LDC,
$ C(II,1), LDC, WORK, INFO )
WORK(1)= N * NB
ELSE IF(RIGHT) THEN
WORK(1)= MB * NB
- END IF
+ END IF
RETURN
*
* End of CLAMTSQR
*
- END
\ No newline at end of file
+ END
-*
+*
* Definition:
* ===========
*
* SUBROUTINE CLASWLQ( M, N, MB, NB, A, LDA, T, LDT, WORK,
* LWORK, INFO)
-*
+*
* .. Scalar Arguments ..
* INTEGER INFO, LDA, M, N, MB, NB, LDT, LWORK
* ..
* .. Array Arguments ..
* COMPLEX A( LDA, * ), T( LDT, * ), WORK( * )
* ..
-*
+*
*
*> \par Purpose:
* =============
*>
*> \verbatim
-*>
-*> CLASWLQ computes a blocked Short-Wide LQ factorization of a
+*>
+*> CLASWLQ computes a blocked Short-Wide LQ factorization of a
*> M-by-N matrix A, where N >= M:
*> A = L * Q
*> \endverbatim
*> \param[in] MB
*> \verbatim
*> MB is INTEGER
-*> The row block size to be used in the blocked QR.
-*> M >= MB >= 1
+*> The row block size to be used in the blocked QR.
+*> M >= MB >= 1
*> \endverbatim
*> \param[in] NB
*> \verbatim
*> NB is INTEGER
-*> The column block size to be used in the blocked QR.
+*> The column block size to be used in the blocked QR.
*> NB > M.
*> \endverbatim
*>
*> \verbatim
*> A is COMPLEX array, dimension (LDA,N)
*> On entry, the M-by-N matrix A.
-*> On exit, the elements on and bleow the diagonal
-*> of the array contain the N-by-N lower triangular matrix L;
-*> the elements above the diagonal represent Q by the rows
+*> On exit, the elements on and bleow the diagonal
+*> of the array contain the N-by-N lower triangular matrix L;
+*> the elements above the diagonal represent Q by the rows
*> of blocked V (see Further Details).
*>
*> \endverbatim
*>
*> \param[out] T
*> \verbatim
-*> T is COMPLEX array,
-*> dimension (LDT, N * Number_of_row_blocks)
+*> T is COMPLEX array,
+*> dimension (LDT, N * Number_of_row_blocks)
*> where Number_of_row_blocks = CEIL((N-M)/(NB-M))
*> The blocked upper triangular block reflectors stored in compact form
-*> as a sequence of upper triangular blocks.
+*> as a sequence of upper triangular blocks.
*> See Further Details below.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> (workspace) COMPLEX array, dimension (MAX(1,LWORK))
-*>
+*>
*> \endverbatim
*> \param[in] LWORK
*> \verbatim
*> block reflectors, stored in array T(1:LDT,(i-1)*M+1:i*M).
*> The last Q(k) may use fewer rows.
*> For more information see Further Details in TPQRT.
-*>
+*>
*> For more details of the overall algorithm, see the description of
*> Sequential TSQR in Section 2.2 of [1].
*>
*> \endverbatim
*>
* =====================================================================
- SUBROUTINE CLASWLQ( M, N, MB, NB, A, LDA, T, LDT, WORK, LWORK,
+ SUBROUTINE CLASWLQ( M, N, MB, NB, A, LDA, T, LDT, WORK, LWORK,
$ INFO)
*
* -- LAPACK computational routine (version 3.5.0) --
ELSE IF( N.LT.0 .OR. N.LT.M ) THEN
INFO = -2
ELSE IF( MB.LT.1 .OR. ( MB.GT.M .AND. M.GT.0 )) THEN
- INFO = -3
+ INFO = -3
ELSE IF( NB.LE.M ) THEN
INFO = -4
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
ELSE IF( LDT.LT.MB ) THEN
INFO = -8
ELSE IF( ( LWORK.LT.M*MB) .AND. (.NOT.LQUERY) ) THEN
- INFO = -10
- END IF
- IF( INFO.EQ.0) THEN
+ INFO = -10
+ END IF
+ IF( INFO.EQ.0) THEN
WORK(1) = MB*M
END IF
*
IF((M.GE.N).OR.(NB.LE.M).OR.(NB.GE.N)) THEN
CALL CGELQT( M, N, MB, A, LDA, T, LDT, WORK, INFO)
RETURN
- END IF
-*
+ END IF
+*
KK = MOD((N-M),(NB-M))
- II=N-KK+1
+ II=N-KK+1
*
* Compute the LQ factorization of the first block A(1:M,1:NB)
*
CTR = 1
*
DO I = NB+1, II-NB+M , (NB-M)
-*
+*
* Compute the QR factorization of the current block A(1:M,I:I+NB-M)
*
CALL CTPLQT( M, NB-M, 0, MB, A(1,1), LDA, A( 1, I ),
CALL CTPLQT( M, KK, 0, MB, A(1,1), LDA, A( 1, II ),
$ LDA, T(1,CTR*M+1), LDT,
$ WORK, INFO )
- END IF
+ END IF
*
WORK( 1 ) = M * MB
RETURN
-*
+*
* End of CLASWLQ
*
- END
\ No newline at end of file
+ END
-*
+*
* Definition:
* ===========
*
-* SUBROUTINE CLATSQR( M, N, MB, NB, A, LDA, T, LDT, WORK,
+* SUBROUTINE CLATSQR( M, N, MB, NB, A, LDA, T, LDT, WORK,
* LWORK, INFO)
-*
+*
* .. Scalar Arguments ..
* INTEGER INFO, LDA, M, N, MB, NB, LDT, LWORK
* ..
* .. Array Arguments ..
* COMPLEX A( LDA, * ), T( LDT, * ), WORK( * )
* ..
-*
+*
*
*> \par Purpose:
* =============
*>
*> \verbatim
-*>
-*> SLATSQR computes a blocked Tall-Skinny QR factorization of
+*>
+*> SLATSQR computes a blocked Tall-Skinny QR factorization of
*> an M-by-N matrix A, where M >= N:
-*> A = Q * R .
+*> A = Q * R .
*> \endverbatim
*
* Arguments:
*> \param[in] MB
*> \verbatim
*> MB is INTEGER
-*> The row block size to be used in the blocked QR.
+*> The row block size to be used in the blocked QR.
*> MB > N.
*> \endverbatim
*>
*> \param[in] NB
*> \verbatim
*> NB is INTEGER
-*> The column block size to be used in the blocked QR.
+*> The column block size to be used in the blocked QR.
*> N >= NB >= 1.
*> \endverbatim
*>
*> \verbatim
*> A is COMPLEX array, dimension (LDA,N)
*> On entry, the M-by-N matrix A.
-*> On exit, the elements on and above the diagonal
-*> of the array contain the N-by-N upper triangular matrix R;
-*> the elements below the diagonal represent Q by the columns
+*> On exit, the elements on and above the diagonal
+*> of the array contain the N-by-N upper triangular matrix R;
+*> the elements below the diagonal represent Q by the columns
*> of blocked V (see Further Details).
*> \endverbatim
*>
*>
*> \param[out] T
*> \verbatim
-*> T is COMPLEX array,
-*> dimension (LDT, N * Number_of_row_blocks)
+*> T is COMPLEX array,
+*> dimension (LDT, N * Number_of_row_blocks)
*> where Number_of_row_blocks = CEIL((M-N)/(MB-N))
*> The blocked upper triangular block reflectors stored in compact form
-*> as a sequence of upper triangular blocks.
+*> as a sequence of upper triangular blocks.
*> See Further Details below.
*> \endverbatim
*>
*>
*> \param[out] WORK
*> \verbatim
-*> (workspace) COMPLEX array, dimension (MAX(1,LWORK))
+*> (workspace) COMPLEX array, dimension (MAX(1,LWORK))
*> \endverbatim
*>
*> \param[in] LWORK
*> block reflectors, stored in array T(1:LDT,(i-1)*N+1:i*N).
*> The last Q(k) may use fewer rows.
*> For more information see Further Details in TPQRT.
-*>
+*>
*> For more details of the overall algorithm, see the description of
*> Sequential TSQR in Section 2.2 of [1].
*>
*> \endverbatim
*>
* =====================================================================
- SUBROUTINE CLATSQR( M, N, MB, NB, A, LDA, T, LDT, WORK,
+ SUBROUTINE CLATSQR( M, N, MB, NB, A, LDA, T, LDT, WORK,
$ LWORK, INFO)
*
* -- LAPACK computational routine (version 3.5.0) --
ELSE IF( N.LT.0 .OR. M.LT.N ) THEN
INFO = -2
ELSE IF( MB.LE.N ) THEN
- INFO = -3
+ INFO = -3
ELSE IF( NB.LT.1 .OR. ( NB.GT.N .AND. N.GT.0 )) THEN
INFO = -4
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
ELSE IF( LDT.LT.NB ) THEN
INFO = -8
ELSE IF( LWORK.LT.(N*NB) .AND. (.NOT.LQUERY) ) THEN
- INFO = -10
- END IF
+ INFO = -10
+ END IF
IF( INFO.EQ.0) THEN
WORK(1) = NB*N
END IF
IF ((MB.LE.N).OR.(MB.GE.M)) THEN
CALL CGEQRT( M, N, NB, A, LDA, T, LDT, WORK, INFO)
RETURN
- END IF
+ END IF
KK = MOD((M-N),(MB-N))
- II=M-KK+1
+ II=M-KK+1
*
* Compute the QR factorization of the first block A(1:MB,1:N)
*
CTR = 1
*
DO I = MB+1, II-MB+N , (MB-N)
-*
+*
* Compute the QR factorization of the current block A(I:I+MB-N,1:N)
*
CALL CTPQRT( MB-N, N, 0, NB, A(1,1), LDA, A( I, 1 ), LDA,
CALL CTPQRT( KK, N, 0, NB, A(1,1), LDA, A( II, 1 ), LDA,
$ T(1, CTR * N + 1), LDT,
$ WORK, INFO )
- END IF
+ END IF
*
work( 1 ) = N*NB
RETURN
-*
+*
* End of CLATSQR
*
- END
\ No newline at end of file
+ END
*
* SUBROUTINE CTPLQT( M, N, L, MB, A, LDA, B, LDB, T, LDT, WORK,
* INFO )
-*
+*
* .. Scalar Arguments ..
* INTEGER INFO, LDA, LDB, LDT, N, M, L, MB
* ..
* .. Array Arguments ..
* COMPLEX A( LDA, * ), B( LDB, * ), T( LDT, * ), WORK( * )
* ..
-*
+*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
-*> CTPLQT computes a blocked LQ factorization of a complex
-*> "triangular-pentagonal" matrix C, which is composed of a
-*> triangular block A and pentagonal block B, using the compact
+*> CTPLQT computes a blocked LQ factorization of a complex
+*> "triangular-pentagonal" matrix C, which is composed of a
+*> triangular block A and pentagonal block B, using the compact
*> WY representation for Q.
*> \endverbatim
*
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix B, and the order of the
-*> triangular matrix A.
+*> triangular matrix A.
*> M >= 0.
*> \endverbatim
*>
*> \param[in,out] B
*> \verbatim
*> B is COMPLEX array, dimension (LDB,N)
-*> On entry, the pentagonal M-by-N matrix B. The first N-L columns
+*> On entry, the pentagonal M-by-N matrix B. The first N-L columns
*> are rectangular, and the last L columns are lower trapezoidal.
*> On exit, B contains the pentagonal matrix V. See Further Details.
*> \endverbatim
*> The lower triangular block reflectors stored in compact form
*> as a sequence of upper triangular blocks. See Further Details.
*> \endverbatim
-*>
+*>
*> \param[in] LDT
*> \verbatim
*> LDT is INTEGER
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
*> \date November 2013
*
*>
*> \verbatim
*>
-*> The input matrix C is a M-by-(M+N) matrix
+*> The input matrix C is a M-by-(M+N) matrix
*>
*> C = [ A ] [ B ]
-*>
+*>
*>
*> where A is an lower triangular N-by-N matrix, and B is M-by-N pentagonal
*> matrix consisting of a M-by-(N-L) rectangular matrix B1 on left of a M-by-L
*> upper trapezoidal matrix B2:
-*> [ B ] = [ B1 ] [ B2 ]
+*> [ B ] = [ B1 ] [ B2 ]
*> [ B1 ] <- M-by-(N-L) rectangular
*> [ B2 ] <- M-by-L upper trapezoidal.
*>
*> The lower trapezoidal matrix B2 consists of the first L columns of a
-*> N-by-N lower triangular matrix, where 0 <= L <= MIN(M,N). If L=0,
-*> B is rectangular M-by-N; if M=L=N, B is lower triangular.
+*> N-by-N lower triangular matrix, where 0 <= L <= MIN(M,N). If L=0,
+*> B is rectangular M-by-N; if M=L=N, B is lower triangular.
*>
*> The matrix W stores the elementary reflectors H(i) in the i-th row
*> above the diagonal (of A) in the M-by-(M+N) input matrix C
-*> [ C ] = [ A ] [ B ]
+*> [ C ] = [ A ] [ B ]
*> [ A ] <- lower triangular N-by-N
*> [ B ] <- M-by-N pentagonal
*>
*> so that W can be represented as
-*> [ W ] = [ I ] [ V ]
+*> [ W ] = [ I ] [ V ]
*> [ I ] <- identity, N-by-N
*> [ V ] <- M-by-N, same form as B.
*>
*> Thus, all of information needed for W is contained on exit in B, which
-*> we call V above. Note that V has the same form as B; that is,
-*> [ V ] = [ V1 ] [ V2 ]
+*> we call V above. Note that V has the same form as B; that is,
+*> [ V ] = [ V1 ] [ V2 ]
*> [ V1 ] <- M-by-(N-L) rectangular
*> [ V2 ] <- M-by-L lower trapezoidal.
*>
-*> The rows of V represent the vectors which define the H(i)'s.
+*> The rows of V represent the vectors which define the H(i)'s.
*>
*> The number of blocks is B = ceiling(M/MB), where each
-*> block is of order MB except for the last block, which is of order
+*> block is of order MB except for the last block, which is of order
*> IB = M - (M-1)*MB. For each of the B blocks, a upper triangular block
-*> reflector factor is computed: T1, T2, ..., TB. The MB-by-MB (and IB-by-IB
+*> reflector factor is computed: T1, T2, ..., TB. The MB-by-MB (and IB-by-IB
*> for the last block) T's are stored in the MB-by-N matrix T as
*>
*> T = [T1 T2 ... TB].
IF( M.EQ.0 .OR. N.EQ.0 ) RETURN
*
DO I = 1, M, MB
-*
+*
* Compute the QR factorization of the current block
*
IB = MIN( M-I+1, MB )
LB = NB-N+L-I+1
END IF
*
- CALL CTPLQT2( IB, NB, LB, A(I,I), LDA, B( I, 1 ), LDB,
+ CALL CTPLQT2( IB, NB, LB, A(I,I), LDA, B( I, 1 ), LDB,
$ T(1, I ), LDT, IINFO )
*
* Update by applying H**T to B(I+IB:M,:) from the right
*
IF( I+IB.LE.M ) THEN
CALL CTPRFB( 'R', 'N', 'F', 'R', M-I-IB+1, NB, IB, LB,
- $ B( I, 1 ), LDB, T( 1, I ), LDT,
- $ A( I+IB, I ), LDA, B( I+IB, 1 ), LDB,
+ $ B( I, 1 ), LDB, T( 1, I ), LDT,
+ $ A( I+IB, I ), LDA, B( I+IB, 1 ), LDB,
$ WORK, M-I-IB+1)
END IF
END DO
RETURN
-*
+*
* End of CTPLQT
*
END
* ===========
*
* SUBROUTINE CTPLQT2( M, N, L, A, LDA, B, LDB, T, LDT, INFO )
-*
+*
* .. Scalar Arguments ..
* INTEGER INFO, LDA, LDB, LDT, N, M, L
* ..
* .. Array Arguments ..
* COMPLEX A( LDA, * ), B( LDB, * ), T( LDT, * )
* ..
-*
+*
*
*> \par Purpose:
* =============
*> \verbatim
*>
*> CTPLQT2 computes a LQ a factorization of a complex "triangular-pentagonal"
-*> matrix C, which is composed of a triangular block A and pentagonal block B,
+*> matrix C, which is composed of a triangular block A and pentagonal block B,
*> using the compact WY representation for Q.
*> \endverbatim
*
*> \param[in] M
*> \verbatim
*> M is INTEGER
-*> The total number of rows of the matrix B.
+*> The total number of rows of the matrix B.
*> M >= 0.
*> \endverbatim
*>
*> \param[in] L
*> \verbatim
*> L is INTEGER
-*> The number of rows of the lower trapezoidal part of B.
+*> The number of rows of the lower trapezoidal part of B.
*> MIN(M,N) >= L >= 0. See Further Details.
*> \endverbatim
*>
*> \param[in,out] B
*> \verbatim
*> B is COMPLEX array, dimension (LDB,N)
-*> On entry, the pentagonal M-by-N matrix B. The first N-L columns
+*> On entry, the pentagonal M-by-N matrix B. The first N-L columns
*> are rectangular, and the last L columns are lower trapezoidal.
*> On exit, B contains the pentagonal matrix V. See Further Details.
*> \endverbatim
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
*> \date September 2012
*
*>
*> \verbatim
*>
-*> The input matrix C is a M-by-(M+N) matrix
+*> The input matrix C is a M-by-(M+N) matrix
*>
*> C = [ A ][ B ]
-*>
+*>
*>
*> where A is an lower triangular N-by-N matrix, and B is M-by-N pentagonal
*> matrix consisting of a M-by-(N-L) rectangular matrix B1 left of a M-by-L
*> [ B2 ] <- M-by-L lower trapezoidal.
*>
*> The lower trapezoidal matrix B2 consists of the first L columns of a
-*> N-by-N lower triangular matrix, where 0 <= L <= MIN(M,N). If L=0,
-*> B is rectangular M-by-N; if M=L=N, B is lower triangular.
+*> N-by-N lower triangular matrix, where 0 <= L <= MIN(M,N). If L=0,
+*> B is rectangular M-by-N; if M=L=N, B is lower triangular.
*>
*> The matrix W stores the elementary reflectors H(i) in the i-th row
*> above the diagonal (of A) in the M-by-(M+N) input matrix C
*>
*> so that W can be represented as
*>
-*> W = [ I ][ V ]
+*> W = [ I ][ V ]
*> [ I ] <- identity, N-by-N
*> [ V ] <- M-by-N, same form as B.
*>
*> Thus, all of information needed for W is contained on exit in B, which
-*> we call V above. Note that V has the same form as B; that is,
+*> we call V above. Note that V has the same form as B; that is,
*>
-*> W = [ V1 ][ V2 ]
+*> W = [ V1 ][ V2 ]
*> [ V1 ] <- M-by-(N-L) rectangular
*> [ V2 ] <- M-by-L lower trapezoidal.
*>
-*> The rows of V represent the vectors which define the H(i)'s.
+*> The rows of V represent the vectors which define the H(i)'s.
*> The (M+N)-by-(M+N) block reflector H is then given by
*>
*> H = I - W**T * T * W
* Quick return if possible
*
IF( N.EQ.0 .OR. M.EQ.0 ) RETURN
-*
+*
DO I = 1, M
*
* Generate elementary reflector H(I) to annihilate B(I,:)
DO J = 1, M-I
T( M, J ) = (A( I+J, I ))
END DO
- CALL CGEMV( 'N', M-I, P, ONE, B( I+1, 1 ), LDB,
+ CALL CGEMV( 'N', M-I, P, ONE, B( I+1, 1 ), LDB,
$ B( I, 1 ), LDB, ONE, T( M, 1 ), LDT )
*
* C(I+1:M,I:N) = C(I+1:M,I:N) + alpha * C(I,I:N)*W(M-1:1)^H
*
* Rectangular part of B2
*
- CALL CGEMV( 'N', I-1-P, L, ALPHA, B( MP, NP ), LDB,
+ CALL CGEMV( 'N', I-1-P, L, ALPHA, B( MP, NP ), LDB,
$ B( I, NP ), LDB, ZERO, T( I,MP ), LDT )
*
* B1
*
- CALL CGEMV( 'N', I-1, N-L, ALPHA, B, LDB, B( I, 1 ), LDB,
- $ ONE, T( I, 1 ), LDT )
+ CALL CGEMV( 'N', I-1, N-L, ALPHA, B, LDB, B( I, 1 ), LDB,
+ $ ONE, T( I, 1 ), LDT )
*
-
+
*
* T(1:I-1,I) := T(1:I-1,1:I-1) * T(I,1:I-1)
*
END DO
DO J = 1, N-L+P
B(I,J)=CONJG(B(I,J))
- END DO
+ END DO
*
* T(I,I) = tau(I)
*
T(J,I)=ZERO
END DO
END DO
-
+
*
* End of CTPLQT2
*
*
* SUBROUTINE CTPMLQT( SIDE, TRANS, M, N, K, L, MB, V, LDV, T, LDT,
* A, LDA, B, LDB, WORK, INFO )
-*
+*
* .. Scalar Arguments ..
* CHARACTER SIDE, TRANS
* INTEGER INFO, K, LDV, LDA, LDB, M, N, L, MB, LDT
* ..
* .. Array Arguments ..
-* COMPLEX V( LDV, * ), A( LDA, * ), B( LDB, * ),
+* COMPLEX V( LDV, * ), A( LDA, * ), B( LDB, * ),
* $ T( LDT, * ), WORK( * )
* ..
-*
+*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
-*> CTPMQRT applies a complex orthogonal matrix Q obtained from a
+*> CTPMQRT applies a complex orthogonal matrix Q obtained from a
*> "triangular-pentagonal" real block reflector H to a general
*> real matrix C, which consists of two blocks A and B.
*> \endverbatim
*> N is INTEGER
*> The number of columns of the matrix B. N >= 0.
*> \endverbatim
-*>
+*>
*> \param[in] K
*> \verbatim
*> K is INTEGER
*> \param[in] L
*> \verbatim
*> L is INTEGER
-*> The order of the trapezoidal part of V.
+*> The order of the trapezoidal part of V.
*> K >= L >= 0. See Further Details.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX array, dimension
-*> (LDA,N) if SIDE = 'L' or
+*> (LDA,N) if SIDE = 'L' or
*> (LDA,K) if SIDE = 'R'
*> On entry, the K-by-N or M-by-K matrix A.
-*> On exit, A is overwritten by the corresponding block of
+*> On exit, A is overwritten by the corresponding block of
*> Q*C or Q**C*C or C*Q or C*Q**C. See Further Details.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
-*> The leading dimension of the array A.
+*> The leading dimension of the array A.
*> If SIDE = 'L', LDC >= max(1,K);
-*> If SIDE = 'R', LDC >= max(1,M).
+*> If SIDE = 'R', LDC >= max(1,M).
*> \endverbatim
*>
*> \param[in,out] B
*> \param[in] LDB
*> \verbatim
*> LDB is INTEGER
-*> The leading dimension of the array B.
+*> The leading dimension of the array B.
*> LDB >= max(1,M).
*> \endverbatim
*>
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
*> \date November 2015
*
*> \verbatim
*>
*> The columns of the pentagonal matrix V contain the elementary reflectors
-*> H(1), H(2), ..., H(K); V is composed of a rectangular block V1 and a
+*> H(1), H(2), ..., H(K); V is composed of a rectangular block V1 and a
*> trapezoidal block V2:
*>
*> V = [V1] [V2].
-*>
*>
-*> The size of the trapezoidal block V2 is determined by the parameter L,
+*>
+*> The size of the trapezoidal block V2 is determined by the parameter L,
*> where 0 <= L <= K; V2 is lower trapezoidal, consisting of the first L
*> rows of a K-by-K upper triangular matrix. If L=K, V2 is lower triangular;
*> if L=0, there is no trapezoidal block, hence V = V1 is rectangular.
*>
-*> If SIDE = 'L': C = [A] where A is K-by-N, B is M-by-N and V is K-by-M.
-*> [B]
-*>
+*> If SIDE = 'L': C = [A] where A is K-by-N, B is M-by-N and V is K-by-M.
+*> [B]
+*>
*> If SIDE = 'R': C = [A B] where A is M-by-K, B is M-by-N and V is K-by-N.
*>
*> The real orthogonal matrix Q is formed from V and T.
INTEGER INFO, K, LDV, LDA, LDB, M, N, L, MB, LDT
* ..
* .. Array Arguments ..
- COMPLEX V( LDV, * ), A( LDA, * ), B( LDB, * ),
+ COMPLEX V( LDV, * ), A( LDA, * ), B( LDB, * ),
$ T( LDT, * ), WORK( * )
* ..
*
RIGHT = LSAME( SIDE, 'R' )
TRAN = LSAME( TRANS, 'C' )
NOTRAN = LSAME( TRANS, 'N' )
-*
+*
IF ( LEFT ) THEN
LDAQ = MAX( 1, K )
ELSE IF ( RIGHT ) THEN
ELSE IF( K.LT.0 ) THEN
INFO = -5
ELSE IF( L.LT.0 .OR. L.GT.K ) THEN
- INFO = -6
+ INFO = -6
ELSE IF( MB.LT.1 .OR. (MB.GT.K .AND. K.GT.0) ) THEN
INFO = -7
ELSE IF( LDV.LT.K ) THEN
ELSE
LB = 0
END IF
- CALL CTPRFB( 'L', 'C', 'F', 'R', NB, N, IB, LB,
- $ V( I, 1 ), LDV, T( 1, I ), LDT,
+ CALL CTPRFB( 'L', 'C', 'F', 'R', NB, N, IB, LB,
+ $ V( I, 1 ), LDV, T( 1, I ), LDT,
$ A( I, 1 ), LDA, B, LDB, WORK, IB )
END DO
-*
+*
ELSE IF( RIGHT .AND. TRAN ) THEN
*
DO I = 1, K, MB
ELSE
LB = NB-N+L-I+1
END IF
- CALL CTPRFB( 'R', 'N', 'F', 'R', M, NB, IB, LB,
- $ V( I, 1 ), LDV, T( 1, I ), LDT,
+ CALL CTPRFB( 'R', 'N', 'F', 'R', M, NB, IB, LB,
+ $ V( I, 1 ), LDV, T( 1, I ), LDT,
$ A( 1, I ), LDA, B, LDB, WORK, M )
END DO
*
*
KF = ((K-1)/MB)*MB+1
DO I = KF, 1, -MB
- IB = MIN( MB, K-I+1 )
+ IB = MIN( MB, K-I+1 )
NB = MIN( M-L+I+IB-1, M )
IF( I.GE.L ) THEN
LB = 0
ELSE
LB = 0
- END IF
+ END IF
CALL CTPRFB( 'L', 'N', 'F', 'R', NB, N, IB, LB,
- $ V( I, 1 ), LDV, T( 1, I ), LDT,
+ $ V( I, 1 ), LDV, T( 1, I ), LDT,
$ A( I, 1 ), LDA, B, LDB, WORK, IB )
END DO
*
*
KF = ((K-1)/MB)*MB+1
DO I = KF, 1, -MB
- IB = MIN( MB, K-I+1 )
+ IB = MIN( MB, K-I+1 )
NB = MIN( N-L+I+IB-1, N )
IF( I.GE.L ) THEN
LB = 0
LB = NB-N+L-I+1
END IF
CALL CTPRFB( 'R', 'C', 'F', 'R', M, NB, IB, LB,
- $ V( I, 1 ), LDV, T( 1, I ), LDT,
+ $ V( I, 1 ), LDV, T( 1, I ), LDT,
$ A( 1, I ), LDA, B, LDB, WORK, M )
END DO
*
-*
+*
* Definition:
* ===========
*
-* SUBROUTINE DGELQ( M, N, A, LDA, WORK1, LWORK1, WORK2, LWORK2,
+* SUBROUTINE DGELQ( M, N, A, LDA, WORK1, LWORK1, WORK2, LWORK2,
* INFO)
-*
+*
* .. Scalar Arguments ..
* INTEGER INFO, LDA, M, N, LWORK1, LWORK2
* ..
* .. Array Arguments ..
* DOUBLE PRECISION A( LDA, * ), WORK1( * ), WORK2( * )
* ..
-*
+*
*
*> \par Purpose:
* =============
*>
*> \verbatim
-*>
-*> DGELQ computes an LQ factorization of an M-by-N matrix A,
-*> using DLASWLQ when A is short and wide
-*> (N sufficiently greater than M), and otherwise DGELQT:
+*>
+*> DGELQ computes an LQ factorization of an M-by-N matrix A,
+*> using DLASWLQ when A is short and wide
+*> (N sufficiently greater than M), and otherwise DGELQT:
*> A = L * Q .
*> \endverbatim
*
*> \verbatim
*> A is DOUBLE PRECISION array, dimension (LDA,N)
*> On entry, the M-by-N matrix A.
-*> On exit, the elements on and below the diagonal of the array
-*> contain the M-by-min(M,N) lower trapezoidal matrix L
+*> On exit, the elements on and below the diagonal of the array
+*> contain the M-by-min(M,N) lower trapezoidal matrix L
*> (L is lower triangular if M <= N);
-*> the elements above the diagonal are the rows of
+*> the elements above the diagonal are the rows of
*> blocked V representing Q (see Further Details).
*> \endverbatim
*>
*> \verbatim
*> WORK1 is DOUBLE PRECISION array, dimension (MAX(1,LWORK1))
*> WORK1 contains part of the data structure used to store Q.
-*> WORK1(1): algorithm type = 1, to indicate output from
+*> WORK1(1): algorithm type = 1, to indicate output from
*> DLASWLQ or DGELQT
*> WORK1(2): optimum size of WORK1
*> WORK1(3): minimum size of WORK1
*> WORK1(4): horizontal block size
*> WORK1(5): vertical block size
-*> WORK1(6:LWORK1): data structure needed for Q, computed by
+*> WORK1(6:LWORK1): data structure needed for Q, computed by
*> DLASWLQ or DGELQT
*> \endverbatim
*>
*> \verbatim
*> LWORK1 is INTEGER
*> The dimension of the array WORK1.
-*> If LWORK1 = -1, then a query is assumed. In this case the
+*> If LWORK1 = -1, then a query is assumed. In this case the
*> routine calculates the optimal size of WORK1 and
-*> returns this value in WORK1(2), and calculates the minimum
-*> size of WORK1 and returns this value in WORK1(3).
-*> No error message related to LWORK1 is issued by XERBLA when
+*> returns this value in WORK1(2), and calculates the minimum
+*> size of WORK1 and returns this value in WORK1(3).
+*> No error message related to LWORK1 is issued by XERBLA when
*> LWORK1 = -1.
*> \endverbatim
*>
*> \param[out] WORK2
*> \verbatim
*> (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK2))
-*>
+*>
*> \endverbatim
*> \param[in] LWORK2
*> \verbatim
*> LWORK2 is INTEGER
*> The dimension of the array WORK2.
*> If LWORK2 = -1, then a query is assumed. In this case the
-*> routine calculates the optimal size of WORK2 and
+*> routine calculates the optimal size of WORK2 and
*> returns this value in WORK2(1), and calculates the minimum
*> size of WORK2 and returns this value in WORK2(2).
*> No error message related to LWORK2 is issued by XERBLA when
*> Depending on the matrix dimensions M and N, and row and column
*> block sizes MB and NB returned by ILAENV, GELQ will use either
*> LASWLQ(if the matrix is short-and-wide) or GELQT to compute
-*> the LQ decomposition.
+*> the LQ decomposition.
*> The output of LASWLQ or GELQT representing Q is stored in A and in
-*> array WORK1(6:LWORK1) for later use.
-*> WORK1(2:5) contains the matrix dimensions M,N and block sizes MB, NB
-*> which are needed to interpret A and WORK1(6:LWORK1) for later use.
-*> WORK1(1)=1 indicates that the code needed to take WORK1(2:5) and
+*> array WORK1(6:LWORK1) for later use.
+*> WORK1(2:5) contains the matrix dimensions M,N and block sizes MB, NB
+*> which are needed to interpret A and WORK1(6:LWORK1) for later use.
+*> WORK1(1)=1 indicates that the code needed to take WORK1(2:5) and
*> decide whether LASWLQ or GELQT was used is the same as used below in
-*> GELQ. For a detailed description of A and WORK1(6:LWORK1), see
+*> GELQ. For a detailed description of A and WORK1(6:LWORK1), see
*> Further Details in LASWLQ or GELQT.
*> \endverbatim
*>
*>
* =====================================================================
- SUBROUTINE DGELQ( M, N, A, LDA, WORK1, LWORK1, WORK2, LWORK2,
+ SUBROUTINE DGELQ( M, N, A, LDA, WORK1, LWORK1, WORK2, LWORK2,
$ INFO)
*
* -- LAPACK computational routine (version 3.5.0) --
*
LQUERY = ( LWORK1.EQ.-1 .OR. LWORK2.EQ.-1 )
*
-* Determine the block size
-*
+* Determine the block size
+*
IF ( MIN(M,N).GT.0 ) THEN
MB = ILAENV( 1, 'DGELQ ', ' ', M, N, 1, -1)
NB = ILAENV( 1, 'DGELQ ', ' ', M, N, 2, -1)
END IF
*
* Determine if the workspace size satisfies minimum size
-*
+*
LMINWS = .FALSE.
IF((LWORK1.LT.MAX(1,MB*M*NBLCKS+5)
$ .OR.(LWORK2.LT.MB*M)).AND.(LWORK2.GE.M).AND.(LWORK1.GE.M+5)
IF (LWORK1.LT.MAX(1,MB*M*NBLCKS+5)) THEN
LMINWS = .TRUE.
MB = 1
- END IF
+ END IF
IF (LWORK1.LT.MAX(1,M*NBLCKS+5)) THEN
LMINWS = .TRUE.
- NB = N
+ NB = N
END IF
IF (LWORK2.LT.MB*M) THEN
LMINWS = .TRUE.
INFO = -2
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -4
- ELSE IF( LWORK1.LT.MAX( 1, MB*M*NBLCKS+5 )
+ ELSE IF( LWORK1.LT.MAX( 1, MB*M*NBLCKS+5 )
$ .AND.(.NOT.LQUERY).AND. (.NOT.LMINWS)) THEN
INFO = -6
ELSE IF( (LWORK2.LT.MAX(1,M*MB)).AND.(.NOT.LQUERY)
$ .AND.(.NOT.LMINWS) ) THEN
- INFO = -8
- END IF
+ INFO = -8
+ END IF
*
IF( INFO.EQ.0) THEN
WORK1(1) = 1
*
IF((N.LE.M).OR.(NB.LE.M).OR.(NB.GE.N)) THEN
CALL DGELQT( M, N, MB, A, LDA, WORK1(6), MB, WORK2, INFO)
- ELSE
- CALL DLASWLQ( M, N, MB, NB, A, LDA, WORK1(6), MB, WORK2,
+ ELSE
+ CALL DLASWLQ( M, N, MB, NB, A, LDA, WORK1(6), MB, WORK2,
$ LWORK2, INFO)
END IF
RETURN
-*
+*
* End of DGELQ
*
- END
\ No newline at end of file
+ END
*
* =========== DOCUMENTATION ===========
*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
-*> Download DGEQRT + dependencies
-*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dgelqt.f">
-*> [TGZ]</a>
-*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dgelqt.f">
-*> [ZIP]</a>
-*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dgelqt.f">
+*> Download DGEQRT + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dgelqt.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dgelqt.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dgelqt.f">
*> [TXT]</a>
-*> \endhtmlonly
+*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DGELQT( M, N, MB, A, LDA, T, LDT, WORK, INFO )
-*
+*
* .. Scalar Arguments ..
* INTEGER INFO, LDA, LDT, M, N, MB
* ..
* .. Array Arguments ..
* DOUBLE PRECISION A( LDA, * ), T( LDT, * ), WORK( * )
* ..
-*
+*
*
*> \par Purpose:
* =============
*> \verbatim
*>
*> DGELQT computes a blocked LQ factorization of a real M-by-N matrix A
-*> using the compact WY representation of Q.
+*> using the compact WY representation of Q.
*> \endverbatim
*
* Arguments:
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
*> \date November 2013
*
*> V = ( 1 v1 v1 v1 v1 )
*> ( 1 v2 v2 v2 )
*> ( 1 v3 v3 )
-*>
+*>
*>
*> where the vi's represent the vectors which define H(i), which are returned
-*> in the matrix A. The 1's along the diagonal of V are not stored in A.
+*> in the matrix A. The 1's along the diagonal of V are not stored in A.
*> Let K=MIN(M,N). The number of blocks is B = ceiling(K/NB), where each
-*> block is of order NB except for the last block, which is of order
+*> block is of order NB except for the last block, which is of order
*> IB = K - (B-1)*NB. For each of the B blocks, a upper triangular block
-*> reflector factor is computed: T1, T2, ..., TB. The NB-by-NB (and IB-by-IB
+*> reflector factor is computed: T1, T2, ..., TB. The NB-by-NB (and IB-by-IB
*> for the last block) T's are stored in the NB-by-N matrix T as
*>
*> T = (T1 T2 ... TB).
*
DO I = 1, K, MB
IB = MIN( K-I+1, MB )
-*
+*
* Compute the LQ factorization of the current block A(I:M,I:I+IB-1)
-*
+*
CALL DGELQT3( IB, N-I+1, A(I,I), LDA, T(1,I), LDT, IINFO )
IF( I+IB.LE.M ) THEN
*
* Update by applying H**T to A(I:M,I+IB:N) from the right
*
CALL DLARFB( 'R', 'N', 'F', 'R', M-I-IB+1, N-I+1, IB,
- $ A( I, I ), LDA, T( 1, I ), LDT,
+ $ A( I, I ), LDA, T( 1, I ), LDT,
$ A( I+IB, I ), LDA, WORK , M-I-IB+1 )
END IF
END DO
RETURN
-*
+*
* End of DGELQT
*
END
-*
+*
* Definition:
* ===========
*
-* SUBROUTINE DGEMLQ( SIDE, TRANS, M, N, K, A, LDA, WORK1,
+* SUBROUTINE DGEMLQ( SIDE, TRANS, M, N, K, A, LDA, WORK1,
* $ LWORK1, C, LDC, WORK2, LWORK2, INFO )
*
*
* =============
*>
*> \verbatim
-*>
+*>
*> DGEMLQ overwrites the general real M-by-N matrix C with
*>
-*>
+*>
*> SIDE = 'L' SIDE = 'R'
*> TRANS = 'N': Q * C C * Q
*> TRANS = 'T': Q**T * C C * Q**T
-*> where Q is a real orthogonal matrix defined as the product
-*> of blocked elementary reflectors computed by short wide LQ
+*> where Q is a real orthogonal matrix defined as the product
+*> of blocked elementary reflectors computed by short wide LQ
*> factorization (DGELQ)
*> \endverbatim
*
*> The number of elementary reflectors whose product defines
*> the matrix Q.
*> M >= K >= 0;
-*>
+*>
*> \endverbatim
*>
*> \param[in,out] A
*> \param[out] WORK2
*> \verbatim
*> (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK2))
-*>
+*>
*> \endverbatim
*> \param[in] LWORK2
*> \verbatim
*> LWORK2 is INTEGER
-*> The dimension of the array WORK2.
+*> The dimension of the array WORK2.
*> If LWORK2 = -1, then a workspace query is assumed; the routine
*> only calculates the optimal size of the WORK2 array, returns
-*> this value as the third entry of the WORK2 array (WORK2(1)),
+*> this value as the third entry of the WORK2 array (WORK2(1)),
*> and no error message related to LWORK2 is issued by XERBLA.
*>
*> \endverbatim
*> Depending on the matrix dimensions M and N, and row and column
*> block sizes MB and NB returned by ILAENV, GELQ will use either
*> LASWLQ(if the matrix is short-and-wide) or GELQT to compute
-*> the LQ decomposition.
+*> the LQ decomposition.
*> The output of LASWLQ or GELQT representing Q is stored in A and in
-*> array WORK1(6:LWORK1) for later use.
-*> WORK1(2:5) contains the matrix dimensions M,N and block sizes MB, NB
-*> which are needed to interpret A and WORK1(6:LWORK1) for later use.
-*> WORK1(1)=1 indicates that the code needed to take WORK1(2:5) and
+*> array WORK1(6:LWORK1) for later use.
+*> WORK1(2:5) contains the matrix dimensions M,N and block sizes MB, NB
+*> which are needed to interpret A and WORK1(6:LWORK1) for later use.
+*> WORK1(1)=1 indicates that the code needed to take WORK1(2:5) and
*> decide whether LASWLQ or GELQT was used is the same as used below in
-*> GELQ. For a detailed description of A and WORK1(6:LWORK1), see
+*> GELQ. For a detailed description of A and WORK1(6:LWORK1), see
*> Further Details in LASWLQ or GELQT.
*> \endverbatim
*>
* =====================================================================
- SUBROUTINE DGEMLQ( SIDE, TRANS, M, N, K, A, LDA, WORK1, LWORK1,
+ SUBROUTINE DGEMLQ( SIDE, TRANS, M, N, K, A, LDA, WORK1, LWORK1,
$ C, LDC, WORK2, LWORK2, INFO )
*
* -- LAPACK computational routine (version 3.5.0) --
*
IF( MIN(M,N,K).EQ.0 ) THEN
RETURN
- END IF
+ END IF
*
IF((LEFT.AND.M.LE.K).OR.(RIGHT.AND.N.LE.K).OR.(NB.LE.K).OR.
$ (NB.GE.MAX(M,N,K))) THEN
- CALL DGEMLQT( SIDE, TRANS, M, N, K, MB, A, LDA,
- $ WORK1(6), MB, C, LDC, WORK2, INFO)
+ CALL DGEMLQT( SIDE, TRANS, M, N, K, MB, A, LDA,
+ $ WORK1(6), MB, C, LDC, WORK2, INFO)
ELSE
CALL DLAMSWLQ( SIDE, TRANS, M, N, K, MB, NB, A, LDA, WORK1(6),
$ MB, C, LDC, WORK2, LWORK2, INFO )
*
* End of DGEMLQ
*
- END
\ No newline at end of file
+ END
*
* =========== DOCUMENTATION ===========
*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
-*> Download DGEMQRT + dependencies
-*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dgemlqt.f">
-*> [TGZ]</a>
-*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dgemlqt.f">
-*> [ZIP]</a>
-*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dgemlqt.f">
+*> Download DGEMQRT + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dgemlqt.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dgemlqt.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dgemlqt.f">
*> [TXT]</a>
-*> \endhtmlonly
+*> \endhtmlonly
*
* Definition:
* ===========
*
-* SUBROUTINE DGEMLQT( SIDE, TRANS, M, N, K, MB, V, LDV, T, LDT,
+* SUBROUTINE DGEMLQT( SIDE, TRANS, M, N, K, MB, V, LDV, T, LDT,
* C, LDC, WORK, INFO )
-*
+*
* .. Scalar Arguments ..
* CHARACTER SIDE, TRANS
* INTEGER INFO, K, LDV, LDC, M, N, MB, LDT
* .. Array Arguments ..
* DOUBLE PRECISION V( LDV, * ), C( LDC, * ), T( LDT, * ), WORK( * )
* ..
-*
+*
*
*> \par Purpose:
* =============
*>
*> Q = H(1) H(2) . . . H(K) = I - V T V**T
*>
-*> generated using the compact WY representation as returned by DGELQT.
+*> generated using the compact WY representation as returned by DGELQT.
*>
*> Q is of order M if SIDE = 'L' and of order N if SIDE = 'R'.
*> \endverbatim
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
*> \date November 2013
*
*> \ingroup doubleGEcomputational
*
* =====================================================================
- SUBROUTINE DGEMLQT( SIDE, TRANS, M, N, K, MB, V, LDV, T, LDT,
+ SUBROUTINE DGEMLQT( SIDE, TRANS, M, N, K, MB, V, LDV, T, LDT,
$ C, LDC, WORK, INFO )
*
* -- LAPACK computational routine (version 3.5.0) --
RIGHT = LSAME( SIDE, 'R' )
TRAN = LSAME( TRANS, 'T' )
NOTRAN = LSAME( TRANS, 'N' )
-*
+*
IF( LEFT ) THEN
LDWORK = MAX( 1, N )
ELSE IF ( RIGHT ) THEN
*
DO I = 1, K, MB
IB = MIN( MB, K-I+1 )
- CALL DLARFB( 'L', 'T', 'F', 'R', M-I+1, N, IB,
- $ V( I, I ), LDV, T( 1, I ), LDT,
+ CALL DLARFB( 'L', 'T', 'F', 'R', M-I+1, N, IB,
+ $ V( I, I ), LDV, T( 1, I ), LDT,
$ C( I, 1 ), LDC, WORK, LDWORK )
END DO
-*
+*
ELSE IF( RIGHT .AND. TRAN ) THEN
*
DO I = 1, K, MB
IB = MIN( MB, K-I+1 )
- CALL DLARFB( 'R', 'N', 'F', 'R', M, N-I+1, IB,
- $ V( I, I ), LDV, T( 1, I ), LDT,
+ CALL DLARFB( 'R', 'N', 'F', 'R', M, N-I+1, IB,
+ $ V( I, I ), LDV, T( 1, I ), LDT,
$ C( 1, I ), LDC, WORK, LDWORK )
END DO
*
*
KF = ((K-1)/MB)*MB+1
DO I = KF, 1, -MB
- IB = MIN( MB, K-I+1 )
- CALL DLARFB( 'L', 'N', 'F', 'R', M-I+1, N, IB,
- $ V( I, I ), LDV, T( 1, I ), LDT,
+ IB = MIN( MB, K-I+1 )
+ CALL DLARFB( 'L', 'N', 'F', 'R', M-I+1, N, IB,
+ $ V( I, I ), LDV, T( 1, I ), LDT,
$ C( I, 1 ), LDC, WORK, LDWORK )
END DO
*
*
KF = ((K-1)/MB)*MB+1
DO I = KF, 1, -MB
- IB = MIN( MB, K-I+1 )
- CALL DLARFB( 'R', 'T', 'F', 'R', M, N-I+1, IB,
- $ V( I, I ), LDV, T( 1, I ), LDT,
+ IB = MIN( MB, K-I+1 )
+ CALL DLARFB( 'R', 'T', 'F', 'R', M, N-I+1, IB,
+ $ V( I, I ), LDV, T( 1, I ), LDT,
$ C( 1, I ), LDC, WORK, LDWORK )
END DO
*
-*
+*
* Definition:
* ===========
*
-* SUBROUTINE DGEMQR( SIDE, TRANS, M, N, K, A, LDA, WORK1,
+* SUBROUTINE DGEMQR( SIDE, TRANS, M, N, K, A, LDA, WORK1,
* $ LWORK1, C, LDC, WORK2, LWORK2, INFO )
*
*
* DOUBLE PRECISION A( LDA, * ), WORK1( * ), C(LDC, * ),
* $ WORK2( * )
* ..
-*
+*
*
*> \par Purpose:
* =============
*>
*> \verbatim
-*>
+*>
*> SGEMQR overwrites the general real M-by-N matrix C with
*>
-*>
+*>
*> SIDE = 'L' SIDE = 'R'
*> TRANS = 'N': Q * C C * Q
*> TRANS = 'T': Q**T * C C * Q**T
-*> where Q is a real orthogonal matrix defined as the product
-*> of blocked elementary reflectors computed by tall skinny
+*> where Q is a real orthogonal matrix defined as the product
+*> of blocked elementary reflectors computed by tall skinny
*> QR factorization (DGEQR)
*> \endverbatim
*
*> 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,K)
-*> The i-th column must contain the vector which defines the
-*> blockedelementary reflector H(i), for i = 1,2,...,k, as
-*> returned by DGETSQR in the first k columns of
+*> The i-th column must contain the vector which defines the
+*> blockedelementary reflector H(i), for i = 1,2,...,k, as
+*> returned by DGETSQR in the first k columns of
*> its array argument A.
*> \endverbatim
*>
*> \param[out] WORK2
*> \verbatim
*> (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK2))
-*>
+*>
*> \endverbatim
*> \param[in] LWORK2
*> \verbatim
*> LWORK2 is INTEGER
-*> The dimension of the array WORK2.
+*> The dimension of the array WORK2.
*> If LWORK2 = -1, then a workspace query is assumed; the routine
*> only calculates the optimal size of the WORK2 array, returns
-*> this value as the third entry of the WORK2 array (WORK2(1)),
+*> this value as the third entry of the WORK2 array (WORK2(1)),
*> and no error message related to LWORK2 is issued by XERBLA.
*>
*> \endverbatim
*> Depending on the matrix dimensions M and N, and row and column
*> block sizes MB and NB returned by ILAENV, GEQR will use either
*> LATSQR (if the matrix is tall-and-skinny) or GEQRT to compute
-*> the QR decomposition.
+*> the QR decomposition.
*> The output of LATSQR or GEQRT representing Q is stored in A and in
-*> array WORK1(6:LWORK1) for later use.
-*> WORK1(2:5) contains the matrix dimensions M,N and block sizes MB,NB
-*> which are needed to interpret A and WORK1(6:LWORK1) for later use.
-*> WORK1(1)=1 indicates that the code needed to take WORK1(2:5) and
-*> decide whether LATSQR or GEQRT was used is the same as used below in
+*> array WORK1(6:LWORK1) for later use.
+*> WORK1(2:5) contains the matrix dimensions M,N and block sizes MB,NB
+*> which are needed to interpret A and WORK1(6:LWORK1) for later use.
+*> WORK1(1)=1 indicates that the code needed to take WORK1(2:5) and
+*> decide whether LATSQR or GEQRT was used is the same as used below in
*> GEQR. For a detailed description of A and WORK1(6:LWORK1), see
*> Further Details in LATSQR or GEQRT.
*> \endverbatim
*>
* =====================================================================
- SUBROUTINE DGEMQR( SIDE, TRANS, M, N, K, A, LDA, WORK1, LWORK1,
+ SUBROUTINE DGEMQR( SIDE, TRANS, M, N, K, A, LDA, WORK1, LWORK1,
$ C, LDC, WORK2, LWORK2, INFO )
*
* -- LAPACK computational routine (version 3.5.0) --
LOGICAL LSAME
EXTERNAL LSAME
* .. External Subroutines ..
- EXTERNAL DGEMQRT, DTPMQRT, XERBLA
+ EXTERNAL DGEMQRT, DTPMQRT, XERBLA
* .. Intrinsic Functions ..
INTRINSIC INT, MAX, MIN, MOD
* ..
ELSE IF(RIGHT) THEN
LW = MB * NB
MN = N
- END IF
+ END IF
*
IF ((MB.GT.K).AND.(MN.GT.K)) THEN
IF(MOD(MN-K, MB-K).EQ.0) THEN
END IF
*
* Determine the block size if it is tall skinny or short and wide
-*
+*
IF( INFO.EQ.0) THEN
- WORK2(1) = LW
+ WORK2(1) = LW
END IF
*
IF( INFO.NE.0 ) THEN
*
IF((LEFT.AND.M.LE.K).OR.(RIGHT.AND.N.LE.K).OR.(MB.LE.K).OR.
$ (MB.GE.MAX(M,N,K))) THEN
- CALL DGEMQRT( SIDE, TRANS, M, N, K, NB, A, LDA,
- $ WORK1(6), NB, C, LDC, WORK2, INFO)
+ CALL DGEMQRT( SIDE, TRANS, M, N, K, NB, A, LDA,
+ $ WORK1(6), NB, C, LDC, WORK2, INFO)
ELSE
CALL DLAMTSQR( SIDE, TRANS, M, N, K, MB, NB, A, LDA, WORK1(6),
$ NB, C, LDC, WORK2, LWORK2, INFO )
- END IF
+ END IF
*
WORK2(1) = LW
-*
+*
RETURN
*
* End of DGEMQR
*
- END
\ No newline at end of file
+ END
-*
+*
* Definition:
* ===========
*
* SUBROUTINE DGEQR( M, N, A, LDA, WORK1, LWORK1, WORK2, LWORK2,
* INFO)
-*
+*
* .. Scalar Arguments ..
* INTEGER INFO, LDA, M, N, LWORK1, LWORK2
* ..
* .. Array Arguments ..
* DOUBLE PRECISION A( LDA, * ), WORK1( * ), WORK2( * )
* ..
-*
+*
*
*> \par Purpose:
* =============
*>
*> \verbatim
-*>
-*> DGEQR computes a QR factorization of an M-by-N matrix A,
-*> using DLATSQR when A is tall and skinny
-*> (M sufficiently greater than N), and otherwise DGEQRT:
+*>
+*> DGEQR computes a QR factorization of an M-by-N matrix A,
+*> using DLATSQR when A is tall and skinny
+*> (M sufficiently greater than N), and otherwise DGEQRT:
*> A = Q * R .
*> \endverbatim
*
*> A is DOUBLE PRECISION array, dimension (LDA,N)
*> On entry, the M-by-N matrix A.
*> On exit, the elements on and above the diagonal of the array
-*> contain the min(M,N)-by-N upper trapezoidal matrix R
+*> contain the min(M,N)-by-N upper trapezoidal matrix R
*> (R is upper triangular if M >= N);
*> the elements below the diagonal represent Q (see Further Details).
*> \endverbatim
*> \verbatim
*> WORK1 is DOUBLE PRECISION array, dimension (MAX(1,LWORK1))
*> WORK1 contains part of the data structure used to store Q.
-*> WORK1(1): algorithm type = 1, to indicate output from
+*> WORK1(1): algorithm type = 1, to indicate output from
*> DLATSQR or DGEQRT
*> WORK1(2): optimum size of WORK1
*> WORK1(3): minimum size of WORK1
*> WORK1(4): row block size
*> WORK1(5): column block size
-*> WORK1(6:LWORK1): data structure needed for Q, computed by
+*> WORK1(6:LWORK1): data structure needed for Q, computed by
*> DLATSQR or DGEQRT
*> \endverbatim
*>
*> \verbatim
*> LWORK1 is INTEGER
*> The dimension of the array WORK1.
-*> If LWORK1 = -1, then a query is assumed. In this case the
+*> If LWORK1 = -1, then a query is assumed. In this case the
*> routine calculates the optimal size of WORK1 and
-*> returns this value in WORK1(2), and calculates the minimum
-*> size of WORK1 and returns this value in WORK1(3).
-*> No error message related to LWORK1 is issued by XERBLA when
+*> returns this value in WORK1(2), and calculates the minimum
+*> size of WORK1 and returns this value in WORK1(3).
+*> No error message related to LWORK1 is issued by XERBLA when
*> LWORK1 = -1.
*> \endverbatim
*>
*> \param[out] WORK2
*> \verbatim
-*> (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK2))
+*> (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK2))
*> \endverbatim
*>
*> \param[in] LWORK2
*> \verbatim
*> LWORK2 is INTEGER
*> The dimension of the array WORK2.
-*> If LWORK2 = -1, then a query is assumed. In this case the
-*> routine calculates the optimal size of WORK2 and
+*> If LWORK2 = -1, then a query is assumed. In this case the
+*> routine calculates the optimal size of WORK2 and
*> returns this value in WORK2(1), and calculates the minimum
*> size of WORK2 and returns this value in WORK2(2).
*> No error message related to LWORK2 is issued by XERBLA when
*> Depending on the matrix dimensions M and N, and row and column
*> block sizes MB and NB returned by ILAENV, GEQR will use either
*> LATSQR (if the matrix is tall-and-skinny) or GEQRT to compute
-*> the QR decomposition.
+*> the QR decomposition.
*> The output of LATSQR or GEQRT representing Q is stored in A and in
-*> array WORK1(6:LWORK1) for later use.
-*> WORK1(2:5) contains the matrix dimensions M,N and block sizes MB,NB
-*> which are needed to interpret A and WORK1(6:LWORK1) for later use.
-*> WORK1(1)=1 indicates that the code needed to take WORK1(2:5) and
-*> decide whether LATSQR or GEQRT was used is the same as used below in
-*> GEQR. For a detailed description of A and WORK1(6:LWORK1), see
+*> array WORK1(6:LWORK1) for later use.
+*> WORK1(2:5) contains the matrix dimensions M,N and block sizes MB,NB
+*> which are needed to interpret A and WORK1(6:LWORK1) for later use.
+*> WORK1(1)=1 indicates that the code needed to take WORK1(2:5) and
+*> decide whether LATSQR or GEQRT was used is the same as used below in
+*> GEQR. For a detailed description of A and WORK1(6:LWORK1), see
*> Further Details in LATSQR or GEQRT.
*> \endverbatim
*>
* =====================================================================
- SUBROUTINE DGEQR( M, N, A, LDA, WORK1, LWORK1, WORK2, LWORK2,
+ SUBROUTINE DGEQR( M, N, A, LDA, WORK1, LWORK1, WORK2, LWORK2,
$ INFO)
*
* -- LAPACK computational routine (version 3.5.0) --
*
LQUERY = ( LWORK1.EQ.-1 .OR. LWORK2.EQ.-1 )
*
-* Determine the block size
-*
+* Determine the block size
+*
IF ( MIN(M,N).GT.0 ) THEN
MB = ILAENV( 1, 'DGEQR ', ' ', M, N, 1, -1)
NB = ILAENV( 1, 'DGEQR ', ' ', M, N, 2, -1)
END IF
*
* Determine if the workspace size satisfies minimum size
-*
+*
LMINWS = .FALSE.
- IF((LWORK1.LT.MAX(1, NB*N*NBLCKS+5)
- $ .OR.(LWORK2.LT.NB*N)).AND.(LWORK2.GE.N).AND.(LWORK1.GT.N+5)
+ IF((LWORK1.LT.MAX(1, NB*N*NBLCKS+5)
+ $ .OR.(LWORK2.LT.NB*N)).AND.(LWORK2.GE.N).AND.(LWORK1.GT.N+5)
$ .AND.(.NOT.LQUERY)) THEN
IF (LWORK1.LT.MAX(1, NB * N * NBLCKS+5)) THEN
LMINWS = .TRUE.
NB = 1
- END IF
+ END IF
IF (LWORK1.LT.MAX(1, N * NBLCKS+5)) THEN
LMINWS = .TRUE.
- MB = M
+ MB = M
END IF
IF (LWORK2.LT.NB*N) THEN
LMINWS = .TRUE.
INFO = -2
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -4
- ELSE IF( LWORK1.LT.MAX( 1, NB * N * NBLCKS + 5 )
+ ELSE IF( LWORK1.LT.MAX( 1, NB * N * NBLCKS + 5 )
$ .AND.(.NOT.LQUERY).AND.(.NOT.LMINWS)) THEN
INFO = -6
- ELSE IF( (LWORK2.LT.MAX(1,N*NB)).AND.(.NOT.LQUERY)
+ ELSE IF( (LWORK2.LT.MAX(1,N*NB)).AND.(.NOT.LQUERY)
$ .AND.(.NOT.LMINWS)) THEN
- INFO = -8
- END IF
+ INFO = -8
+ END IF
IF( INFO.EQ.0) THEN
WORK1(1) = 1
*
IF((M.LE.N).OR.(MB.LE.N).OR.(MB.GE.M)) THEN
CALL DGEQRT( M, N, NB, A, LDA, WORK1(6), NB, WORK2, INFO)
- ELSE
- CALL DLATSQR( M, N, MB, NB, A, LDA, WORK1(6), NB, WORK2,
+ ELSE
+ CALL DLATSQR( M, N, MB, NB, A, LDA, WORK1(6), NB, WORK2,
$ LWORK2, INFO)
END IF
RETURN
-*
+*
* End of DGEQR
*
- END
\ No newline at end of file
+ END
*
* End of DGETSLS
*
- END
\ No newline at end of file
+ END
-*
+*
* Definition:
* ===========
*
-* SUBROUTINE DLAMSWLQ( SIDE, TRANS, M, N, K, MB, NB, A, LDA, T,
+* SUBROUTINE DLAMSWLQ( SIDE, TRANS, M, N, K, MB, NB, A, LDA, T,
* $ LDT, C, LDC, WORK, LWORK, INFO )
*
*
* =============
*>
*> \verbatim
-*>
+*>
*> DLAMQRTS overwrites the general real M-by-N matrix C with
*>
-*>
+*>
*> SIDE = 'L' SIDE = 'R'
*> TRANS = 'N': Q * C C * Q
*> TRANS = 'T': Q**T * C C * Q**T
*> where Q is a real orthogonal matrix defined as the product of blocked
-*> elementary reflectors computed by short wide LQ
+*> elementary reflectors computed by short wide LQ
*> factorization (DLASWLQ)
*> \endverbatim
*
*> The number of elementary reflectors whose product defines
*> the matrix Q.
*> M >= K >= 0;
-*>
+*>
*> \endverbatim
*> \param[in] MB
*> \verbatim
*> MB is INTEGER
-*> The row block size to be used in the blocked QR.
-*> M >= MB >= 1
+*> The row block size to be used in the blocked QR.
+*> M >= MB >= 1
*> \endverbatim
*>
*> \param[in] NB
*> \verbatim
*> NB is INTEGER
-*> The column block size to be used in the blocked QR.
+*> The column block size to be used in the blocked QR.
*> NB > M.
*> \endverbatim
*>
*> \param[in] NB
*> \verbatim
*> NB is INTEGER
-*> The block size to be used in the blocked QR.
+*> The block size to be used in the blocked QR.
*> MB > M.
-*>
+*>
*> \endverbatim
*>
*> \param[in,out] A
*>
*> \param[in] T
*> \verbatim
-*> T is DOUBLE PRECISION array, dimension
+*> T is DOUBLE PRECISION array, dimension
*> ( M * Number of blocks(CEIL(N-K/NB-K)),
*> The blocked upper triangular block reflectors stored in compact form
*> as a sequence of upper triangular blocks. See below
*> \param[out] WORK
*> \verbatim
*> (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
-*>
+*>
*> \endverbatim
*> \param[in] LWORK
*> \verbatim
*> block reflectors, stored in array T(1:LDT,(i-1)*M+1:i*M).
*> The last Q(k) may use fewer rows.
*> For more information see Further Details in TPQRT.
-*>
+*>
*> For more details of the overall algorithm, see the description of
*> Sequential TSQR in Section 2.2 of [1].
*>
*> \endverbatim
*>
* =====================================================================
- SUBROUTINE DLAMSWLQ( SIDE, TRANS, M, N, K, MB, NB, A, LDA, T,
+ SUBROUTINE DLAMSWLQ( SIDE, TRANS, M, N, K, MB, NB, A, LDA, T,
$ LDT, C, LDC, WORK, LWORK, INFO )
*
* -- LAPACK computational routine (version 3.5.0) --
*
IF( MIN(M,N,K).EQ.0 ) THEN
RETURN
- END IF
+ END IF
*
IF((NB.LE.K).OR.(NB.GE.MAX(M,N,K))) THEN
- CALL DGEMLQT( SIDE, TRANS, M, N, K, MB, A, LDA,
- $ T, LDT, C, LDC, WORK, INFO)
+ CALL DGEMLQT( SIDE, TRANS, M, N, K, MB, A, LDA,
+ $ T, LDT, C, LDC, WORK, INFO)
RETURN
END IF
*
*
* Multiply Q to the current block of C (1:M,I:I+MB)
*
- CTR = CTR - 1
+ CTR = CTR - 1
CALL DTPMLQT('R','N', M, NB-K, K, 0, MB, A(1, I), LDA,
$ T(1,CTR*K+1), LDT, C(1,1), LDC,
$ C(1,I), LDC, WORK, INFO )
IF(II.LE.N) THEN
*
* Multiply Q to the last block of C
-*
+*
CALL DTPMLQT('R','T',M , KK, K, 0,MB, A(1,II), LDA,
$ T(1,CTR*K+1),LDT, C(1,1), LDC,
$ C(1,II), LDC, WORK, INFO )
*
* End of DLAMSWLQ
*
- END
\ No newline at end of file
+ END
-*
+*
* Definition:
* ===========
*
-* SUBROUTINE DLAMTSQR( SIDE, TRANS, M, N, K, MB, NB, A, LDA, T,
+* SUBROUTINE DLAMTSQR( SIDE, TRANS, M, N, K, MB, NB, A, LDA, T,
* $ LDT, C, LDC, WORK, LWORK, INFO )
*
*
* =============
*>
*> \verbatim
-*>
+*>
*> DLAMTSQR overwrites the general real M-by-N matrix C with
*>
-*>
+*>
*> SIDE = 'L' SIDE = 'R'
*> TRANS = 'N': Q * C C * Q
*> TRANS = 'T': Q**T * C C * Q**T
-*> where Q is a real orthogonal matrix defined as the product
-*> of blocked elementary reflectors computed by tall skinny
+*> where Q is a real orthogonal matrix defined as the product
+*> of blocked elementary reflectors computed by tall skinny
*> QR factorization (DLATSQR)
*> \endverbatim
*
*> The number of elementary reflectors whose product defines
*> the matrix Q.
*> N >= K >= 0;
-*>
+*>
*> \endverbatim
*>
*> \param[in] MB
*> \verbatim
*> MB is INTEGER
-*> The block size to be used in the blocked QR.
+*> The block size to be used in the blocked QR.
*> MB > N. (must be the same as DLATSQR)
*> \endverbatim
*>
*> \param[in] NB
*> \verbatim
*> NB is INTEGER
-*> The column block size to be used in the blocked QR.
+*> The column block size to be used in the blocked QR.
*> N >= NB >= 1.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is DOUBLE PRECISION array, dimension (LDA,K)
-*> The i-th column must contain the vector which defines the
-*> blockedelementary reflector H(i), for i = 1,2,...,k, as
-*> returned by DLATSQR in the first k columns of
+*> The i-th column must contain the vector which defines the
+*> blockedelementary reflector H(i), for i = 1,2,...,k, as
+*> returned by DLATSQR in the first k columns of
*> its array argument A.
*> \endverbatim
*>
*>
*> \param[in] T
*> \verbatim
-*> T is DOUBLE PRECISION array, dimension
+*> T is DOUBLE PRECISION array, dimension
*> ( N * Number of blocks(CEIL(M-K/MB-K)),
*> The blocked upper triangular block reflectors stored in compact form
*> as a sequence of upper triangular blocks. See below
*> \param[out] WORK
*> \verbatim
*> (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
-*>
+*>
*> \endverbatim
*> \param[in] LWORK
*> \verbatim
*> LWORK is INTEGER
*> The dimension of the array WORK.
-*>
+*>
*> If SIDE = 'L', LWORK >= max(1,N)*NB;
*> if SIDE = 'R', LWORK >= max(1,MB)*NB.
*> If LWORK = -1, then a workspace query is assumed; the routine
*> block reflectors, stored in array T(1:LDT,(i-1)*N+1:i*N).
*> The last Q(k) may use fewer rows.
*> For more information see Further Details in TPQRT.
-*>
+*>
*> For more details of the overall algorithm, see the description of
*> Sequential TSQR in Section 2.2 of [1].
*>
*> \endverbatim
*>
* =====================================================================
- SUBROUTINE DLAMTSQR( SIDE, TRANS, M, N, K, MB, NB, A, LDA, T,
+ SUBROUTINE DLAMTSQR( SIDE, TRANS, M, N, K, MB, NB, A, LDA, T,
$ LDT, C, LDC, WORK, LWORK, INFO )
*
* -- LAPACK computational routine (version 3.5.0) --
LOGICAL LSAME
EXTERNAL LSAME
* .. External Subroutines ..
- EXTERNAL DGEMQRT, DTPMQRT, XERBLA
+ EXTERNAL DGEMQRT, DTPMQRT, XERBLA
* ..
* .. Executable Statements ..
*
END IF
*
* Determine the block size if it is tall skinny or short and wide
-*
+*
IF( INFO.EQ.0) THEN
WORK(1) = LW
END IF
END IF
*
IF((MB.LE.K).OR.(MB.GE.MAX(M,N,K))) THEN
- CALL DGEMQRT( SIDE, TRANS, M, N, K, NB, A, LDA,
- $ T, LDT, C, LDC, WORK, INFO)
+ CALL DGEMQRT( SIDE, TRANS, M, N, K, NB, A, LDA,
+ $ T, LDT, C, LDC, WORK, INFO)
RETURN
- END IF
+ END IF
*
IF(LEFT.AND.NOTRAN) THEN
*
IF(II.LE.M) THEN
*
* Multiply Q to the last block of C
-*
+*
CALL DTPMQRT('L','T',KK , N, K, 0,NB, A(II,1), LDA,
$ T(1,CTR * K + 1), LDT, C(1,1), LDC,
$ C(II,1), LDC, WORK, INFO )
*
END IF
*
- WORK(1) = LW
+ WORK(1) = LW
RETURN
*
* End of DLAMTSQR
*
- END
\ No newline at end of file
+ END
-*
+*
* Definition:
* ===========
*
* SUBROUTINE DLASWLQ( M, N, MB, NB, A, LDA, T, LDT, WORK,
* LWORK, INFO)
-*
+*
* .. Scalar Arguments ..
* INTEGER INFO, LDA, M, N, MB, NB, LDT, LWORK
* ..
* .. Array Arguments ..
* DOUBLE PRECISION A( LDA, * ), T( LDT, * ), WORK( * )
* ..
-*
+*
*
*> \par Purpose:
* =============
*>
*> \verbatim
-*>
-*> DLASWLQ computes a blocked Short-Wide LQ factorization of a
+*>
+*> DLASWLQ computes a blocked Short-Wide LQ factorization of a
*> M-by-N matrix A, where N >= M:
*> A = L * Q
*> \endverbatim
*> \param[in] MB
*> \verbatim
*> MB is INTEGER
-*> The row block size to be used in the blocked QR.
-*> M >= MB >= 1
+*> The row block size to be used in the blocked QR.
+*> M >= MB >= 1
*> \endverbatim
*> \param[in] NB
*> \verbatim
*> NB is INTEGER
-*> The column block size to be used in the blocked QR.
+*> The column block size to be used in the blocked QR.
*> NB > M.
*> \endverbatim
*>
*> \verbatim
*> A is DOUBLE PRECISION array, dimension (LDA,N)
*> On entry, the M-by-N matrix A.
-*> On exit, the elements on and bleow the diagonal
-*> of the array contain the N-by-N lower triangular matrix L;
-*> the elements above the diagonal represent Q by the rows
+*> On exit, the elements on and bleow the diagonal
+*> of the array contain the N-by-N lower triangular matrix L;
+*> the elements above the diagonal represent Q by the rows
*> of blocked V (see Further Details).
*>
*> \endverbatim
*>
*> \param[out] T
*> \verbatim
-*> T is DOUBLE PRECISION array,
-*> dimension (LDT, N * Number_of_row_blocks)
+*> T is DOUBLE PRECISION array,
+*> dimension (LDT, N * Number_of_row_blocks)
*> where Number_of_row_blocks = CEIL((N-M)/(NB-M))
*> The blocked upper triangular block reflectors stored in compact form
-*> as a sequence of upper triangular blocks.
+*> as a sequence of upper triangular blocks.
*> See Further Details below.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
-*>
+*>
*> \endverbatim
*> \param[in] LWORK
*> \verbatim
*> block reflectors, stored in array T(1:LDT,(i-1)*M+1:i*M).
*> The last Q(k) may use fewer rows.
*> For more information see Further Details in TPQRT.
-*>
+*>
*> For more details of the overall algorithm, see the description of
*> Sequential TSQR in Section 2.2 of [1].
*>
*> \endverbatim
*>
* =====================================================================
- SUBROUTINE DLASWLQ( M, N, MB, NB, A, LDA, T, LDT, WORK, LWORK,
+ SUBROUTINE DLASWLQ( M, N, MB, NB, A, LDA, T, LDT, WORK, LWORK,
$ INFO)
*
* -- LAPACK computational routine (version 3.5.0) --
ELSE IF( N.LT.0 .OR. N.LT.M ) THEN
INFO = -2
ELSE IF( MB.LT.1 .OR. ( MB.GT.M .AND. M.GT.0 )) THEN
- INFO = -3
+ INFO = -3
ELSE IF( NB.LE.M ) THEN
INFO = -4
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
ELSE IF( LDT.LT.MB ) THEN
INFO = -8
ELSE IF( ( LWORK.LT.M*MB) .AND. (.NOT.LQUERY) ) THEN
- INFO = -10
- END IF
- IF( INFO.EQ.0) THEN
+ INFO = -10
+ END IF
+ IF( INFO.EQ.0) THEN
WORK(1) = MB*M
END IF
*
IF((M.GE.N).OR.(NB.LE.M).OR.(NB.GE.N)) THEN
CALL DGELQT( M, N, MB, A, LDA, T, LDT, WORK, INFO)
RETURN
- END IF
-*
+ END IF
+*
KK = MOD((N-M),(NB-M))
- II=N-KK+1
+ II=N-KK+1
*
* Compute the LQ factorization of the first block A(1:M,1:NB)
*
CTR = 1
*
DO I = NB+1, II-NB+M , (NB-M)
-*
+*
* Compute the QR factorization of the current block A(1:M,I:I+NB-M)
*
CALL DTPLQT( M, NB-M, 0, MB, A(1,1), LDA, A( 1, I ),
CALL DTPLQT( M, KK, 0, MB, A(1,1), LDA, A( 1, II ),
$ LDA, T(1, CTR * M + 1), LDT,
$ WORK, INFO )
- END IF
+ END IF
*
WORK( 1 ) = M * MB
RETURN
-*
+*
* End of DLASWLQ
*
- END
\ No newline at end of file
+ END
*
* =========== DOCUMENTATION ===========
*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
-*> Download DLASYF_AASEN + dependencies
-*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlasyf_aasen.f">
-*> [TGZ]</a>
-*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlasyf_aasen.f">
-*> [ZIP]</a>
-*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlasyf_aasen.f">
+*> Download DLASYF_AASEN + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlasyf_aasen.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlasyf_aasen.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlasyf_aasen.f">
*> [TXT]</a>
-*> \endhtmlonly
+*> \endhtmlonly
*
* Definition:
* ===========
*
-* SUBROUTINE DLASYF_AASEN( UPLO, J1, M, NB, A, LDA, IPIV,
+* SUBROUTINE DLASYF_AASEN( UPLO, J1, M, NB, A, LDA, IPIV,
* H, LDH, WORK, INFO )
-*
+*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER J1, M, NB, LDA, LDH, INFO
* INTEGER IPIV( * )
* DOUBLE PRECISION A( LDA, * ), H( LDH, * ), WORK( * )
* ..
-*
+*
*
*> \par Purpose:
* =============
*> last row, or column, of the previous panel. The first row, or column,
*> of A is set to be the first row, or column, of an identity matrix,
*> which is used to factorize the first panel.
-*>
+*>
*> The resulting J-th row of U, or J-th column of L, is stored in the
-*> (J-1)-th row, or column, of A (without the unit diatonals), while
+*> (J-1)-th row, or column, of A (without the unit diatonals), while
*> the diagonal and subdiagonal of A are overwritten by those of T.
*>
*> \endverbatim
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
*> \date November 2016
*
* @precisions fortran d -> s
*
* =====================================================================
- SUBROUTINE DLASYF_AASEN( UPLO, J1, M, NB, A, LDA, IPIV,
+ SUBROUTINE DLASYF_AASEN( UPLO, J1, M, NB, A, LDA, IPIV,
$ H, LDH, WORK, INFO )
*
* -- LAPACK computational routine (version 3.4.0) --
*
* .. Local Scalars ..
INTEGER J, K, K1, I1, I2
- DOUBLE PRECISION PIV, ALPHA
+ DOUBLE PRECISION PIV, ALPHA
* ..
* .. External Functions ..
LOGICAL LSAME
*
A( K, J ) = WORK( 1 )
*
- IF( J.LT.M ) THEN
+ IF( J.LT.M ) THEN
*
* Compute WORK(2:N) = T(J, J) L(J, (J+1):N)
* where A(J, J) stores T(J, J) and A(J-1, (J+1):N) stores U(J, (J+1):N)
*
IF( (J1+J-1).GT.1 ) THEN
- ALPHA = -A( K, J )
- CALL DAXPY( M-J, ALPHA, A( K-1, J+1 ), LDA,
+ ALPHA = -A( K, J )
+ CALL DAXPY( M-J, ALPHA, A( K-1, J+1 ), LDA,
$ WORK( 2 ), 1 )
ENDIF
*
*
I1 = I1+J-1
I2 = I2+J-1
- CALL DSWAP( I2-I1-1, A( J1+I1-1, I1+1 ), LDA,
+ CALL DSWAP( I2-I1-1, A( J1+I1-1, I1+1 ), LDA,
$ A( J1+I1, I2 ), 1 )
*
* Swap A(I1, I2+1:N) with A(I2, I2+1:N)
*
- CALL DSWAP( M-I2, A( J1+I1-1, I2+1 ), LDA,
+ CALL DSWAP( M-I2, A( J1+I1-1, I2+1 ), LDA,
$ A( J1+I2-1, I2+1 ), LDA )
*
* Swap A(I1, I1) with A(I2,I2)
* Swap L(1:I1-1, I1) with L(1:I1-1, I2),
* skipping the first column
*
- CALL DSWAP( I1-K1+1, A( 1, I1 ), 1,
+ CALL DSWAP( I1-K1+1, A( 1, I1 ), 1,
$ A( 1, I2 ), 1 )
END IF
- ELSE
+ ELSE
IPIV( J+1 ) = J+1
ENDIF
*
* Set A(J, J+1) = T(J, J+1)
*
A( K, J+1 ) = WORK( 2 )
- IF( (A( K, J ).EQ.ZERO ) .AND.
+ IF( (A( K, J ).EQ.ZERO ) .AND.
$ ( (J.EQ.M) .OR. (A( K, J+1 ).EQ.ZERO))) THEN
IF(INFO .EQ. 0) THEN
INFO = J
*
IF( J.LT.NB ) THEN
*
-* Copy A(J+1:N, J+1) into H(J:N, J),
+* Copy A(J+1:N, J+1) into H(J:N, J),
*
- CALL DCOPY( M-J, A( K+1, J+1 ), LDA,
+ CALL DCOPY( M-J, A( K+1, J+1 ), LDA,
$ H( J+1, J+1 ), 1 )
END IF
*
CALL DCOPY( M-J-1, WORK( 3 ), 1, A( K, J+2 ), LDA )
CALL DSCAL( M-J-1, ALPHA, A( K, J+2 ), LDA )
ELSE
- CALL DLASET( 'Full', 1, M-J-1, ZERO, ZERO,
+ CALL DLASET( 'Full', 1, M-J-1, ZERO, ZERO,
$ A( K, J+2 ), LDA)
END IF
ELSE
*
A( J, K ) = WORK( 1 )
*
- IF( J.LT.M ) THEN
+ IF( J.LT.M ) THEN
*
* Compute WORK(2:N) = T(J, J) L((J+1):N, J)
* where A(J, J) = T(J, J) and A((J+1):N, J-1) = L((J+1):N, J)
*
IF( (J1+J-1).GT.1 ) THEN
- ALPHA = -A( J, K )
- CALL DAXPY( M-J, ALPHA, A( J+1, K-1 ), 1,
+ ALPHA = -A( J, K )
+ CALL DAXPY( M-J, ALPHA, A( J+1, K-1 ), 1,
$ WORK( 2 ), 1 )
ENDIF
*
*
I1 = I1+J-1
I2 = I2+J-1
- CALL DSWAP( I2-I1-1, A( I1+1, J1+I1-1 ), 1,
+ CALL DSWAP( I2-I1-1, A( I1+1, J1+I1-1 ), 1,
$ A( I2, J1+I1 ), LDA )
*
* Swap A(I2+1:N, I1) with A(I2+1:N, I2)
*
- CALL DSWAP( M-I2, A( I2+1, J1+I1-1 ), 1,
+ CALL DSWAP( M-I2, A( I2+1, J1+I1-1 ), 1,
$ A( I2+1, J1+I2-1 ), 1 )
*
* Swap A(I1, I1) with A(I2, I2)
* Swap L(1:I1-1, I1) with L(1:I1-1, I2),
* skipping the first column
*
- CALL DSWAP( I1-K1+1, A( I1, 1 ), LDA,
+ CALL DSWAP( I1-K1+1, A( I1, 1 ), LDA,
$ A( I2, 1 ), LDA )
END IF
- ELSE
+ ELSE
IPIV( J+1 ) = J+1
ENDIF
*
* Set A(J+1, J) = T(J+1, J)
*
A( J+1, K ) = WORK( 2 )
- IF( (A( J, K ).EQ.ZERO) .AND.
+ IF( (A( J, K ).EQ.ZERO) .AND.
$ ( (J.EQ.M) .OR. (A( J+1, K ).EQ.ZERO)) ) THEN
- IF (INFO .EQ. 0)
+ IF (INFO .EQ. 0)
$ INFO = J
END IF
*
IF( J.LT.NB ) THEN
*
-* Copy A(J+1:N, J+1) into H(J+1:N, J),
+* Copy A(J+1:N, J+1) into H(J+1:N, J),
*
- CALL DCOPY( M-J, A( J+1, K+1 ), 1,
+ CALL DCOPY( M-J, A( J+1, K+1 ), 1,
$ H( J+1, J+1 ), 1 )
END IF
*
CALL DCOPY( M-J-1, WORK( 3 ), 1, A( J+2, K ), 1 )
CALL DSCAL( M-J-1, ALPHA, A( J+2, K ), 1 )
ELSE
- CALL DLASET( 'Full', M-J-1, 1, ZERO, ZERO,
+ CALL DLASET( 'Full', M-J-1, 1, ZERO, ZERO,
$ A( J+2, K ), LDA )
END IF
ELSE
-*
+*
* Definition:
* ===========
*
-* SUBROUTINE DLATSQR( M, N, MB, NB, A, LDA, T, LDT, WORK,
+* SUBROUTINE DLATSQR( M, N, MB, NB, A, LDA, T, LDT, WORK,
* LWORK, INFO)
-*
+*
* .. Scalar Arguments ..
* INTEGER INFO, LDA, M, N, MB, NB, LDT, LWORK
* ..
* .. Array Arguments ..
* DOUBLE PRECISION A( LDA, * ), T( LDT, * ), WORK( * )
* ..
-*
+*
*
*> \par Purpose:
* =============
*>
*> \verbatim
-*>
-*> DLATSQR computes a blocked Tall-Skinny QR factorization of
+*>
+*> DLATSQR computes a blocked Tall-Skinny QR factorization of
*> an M-by-N matrix A, where M >= N:
-*> A = Q * R .
+*> A = Q * R .
*> \endverbatim
*
* Arguments:
*> \param[in] MB
*> \verbatim
*> MB is INTEGER
-*> The row block size to be used in the blocked QR.
+*> The row block size to be used in the blocked QR.
*> MB > N.
*> \endverbatim
*>
*> \param[in] NB
*> \verbatim
*> NB is INTEGER
-*> The column block size to be used in the blocked QR.
+*> The column block size to be used in the blocked QR.
*> N >= NB >= 1.
*> \endverbatim
*>
*> \verbatim
*> A is DOUBLE PRECISION array, dimension (LDA,N)
*> On entry, the M-by-N matrix A.
-*> On exit, the elements on and above the diagonal
-*> of the array contain the N-by-N upper triangular matrix R;
-*> the elements below the diagonal represent Q by the columns
+*> On exit, the elements on and above the diagonal
+*> of the array contain the N-by-N upper triangular matrix R;
+*> the elements below the diagonal represent Q by the columns
*> of blocked V (see Further Details).
*> \endverbatim
*>
*>
*> \param[out] T
*> \verbatim
-*> T is DOUBLE PRECISION array,
-*> dimension (LDT, N * Number_of_row_blocks)
+*> T is DOUBLE PRECISION array,
+*> dimension (LDT, N * Number_of_row_blocks)
*> where Number_of_row_blocks = CEIL((M-N)/(MB-N))
*> The blocked upper triangular block reflectors stored in compact form
-*> as a sequence of upper triangular blocks.
+*> as a sequence of upper triangular blocks.
*> See Further Details below.
*> \endverbatim
*>
*>
*> \param[out] WORK
*> \verbatim
-*> (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+*> (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
*> \endverbatim
*>
*> \param[in] LWORK
*> block reflectors, stored in array T(1:LDT,(i-1)*N+1:i*N).
*> The last Q(k) may use fewer rows.
*> For more information see Further Details in TPQRT.
-*>
+*>
*> For more details of the overall algorithm, see the description of
*> Sequential TSQR in Section 2.2 of [1].
*>
*> \endverbatim
*>
* =====================================================================
- SUBROUTINE DLATSQR( M, N, MB, NB, A, LDA, T, LDT, WORK,
+ SUBROUTINE DLATSQR( M, N, MB, NB, A, LDA, T, LDT, WORK,
$ LWORK, INFO)
*
* -- LAPACK computational routine (version 3.5.0) --
ELSE IF( N.LT.0 .OR. M.LT.N ) THEN
INFO = -2
ELSE IF( MB.LE.N ) THEN
- INFO = -3
+ INFO = -3
ELSE IF( NB.LT.1 .OR. ( NB.GT.N .AND. N.GT.0 )) THEN
INFO = -4
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
ELSE IF( LDT.LT.NB ) THEN
INFO = -8
ELSE IF( LWORK.LT.(N*NB) .AND. (.NOT.LQUERY) ) THEN
- INFO = -10
- END IF
+ INFO = -10
+ END IF
IF( INFO.EQ.0) THEN
WORK(1) = NB*N
END IF
IF ((MB.LE.N).OR.(MB.GE.M)) THEN
CALL DGEQRT( M, N, NB, A, LDA, T, LDT, WORK, INFO)
RETURN
- END IF
+ END IF
*
KK = MOD((M-N),(MB-N))
- II=M-KK+1
+ II=M-KK+1
*
* Compute the QR factorization of the first block A(1:MB,1:N)
*
*
CTR = 1
DO I = MB+1, II-MB+N , (MB-N)
-*
+*
* Compute the QR factorization of the current block A(I:I+MB-N,1:N)
*
CALL DTPQRT( MB-N, N, 0, NB, A(1,1), LDA, A( I, 1 ), LDA,
CALL DTPQRT( KK, N, 0, NB, A(1,1), LDA, A( II, 1 ), LDA,
$ T(1, CTR * N + 1), LDT,
$ WORK, INFO )
- END IF
+ END IF
*
WORK( 1 ) = N*NB
RETURN
-*
+*
* End of DLATSQR
*
- END
\ No newline at end of file
+ END
*> indicating the nonzero elements in Z. The i-th eigenvector
*> is nonzero only in elements ISUPPZ( 2*i-1 ) through
*> ISUPPZ( 2*i ). This is an output of DSTEMR (tridiagonal
-*> matrix). The support of the eigenvectors of A is typically
+*> matrix). The support of the eigenvectors of A is typically
*> 1:N because of the orthogonal transformations applied by DORMTR.
*> Implemented only for RANGE = 'A' or 'I' and IU - IL = N - 1
*> \endverbatim
*
* =========== DOCUMENTATION ===========
*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
-*> Download DSYSV_AASEN + dependencies
-*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dsysv_aasen.f">
-*> [TGZ]</a>
-*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dsysv_aasen.f">
-*> [ZIP]</a>
-*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dsysv_aasen.f">
+*> Download DSYSV_AASEN + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dsysv_aasen.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dsysv_aasen.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dsysv_aasen.f">
*> [TXT]</a>
-*> \endhtmlonly
+*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DSYSV_AASEN( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK,
* LWORK, INFO )
-*
+*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER N, NRHS, LDA, LDB, LWORK, INFO
* INTEGER IPIV( * )
* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), WORK( * )
* ..
-*
+*
*
*> \par Purpose:
* =============
*> A = U * T * U**T, if UPLO = 'U', or
*> A = L * T * L**T, if UPLO = 'L',
*> where U (or L) is a product of permutation and unit upper (lower)
-*> triangular matrices, and T is symmetric tridiagonal. The factored
+*> triangular matrices, and T is symmetric tridiagonal. The factored
*> form of A is then used to solve the system of equations A * X = B.
*> \endverbatim
*
*> \param[out] IPIV
*> \verbatim
*> IPIV is INTEGER array, dimension (N)
-*> On exit, it contains the details of the interchanges, i.e.,
-*> the row and column k of A were interchanged with the
+*> On exit, it contains the details of the interchanges, i.e.,
+*> the row and column k of A were interchanged with the
*> row and column IPIV(k).
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*> LWORK is INTEGER
-*> The length of WORK. LWORK >= MAX(2*N, 3*N-2), and for
-*> the best performance, LWORK >= max(1,N*NB), where NB is
+*> The length of WORK. LWORK >= MAX(2*N, 3*N-2), and for
+*> the best performance, LWORK >= max(1,N*NB), where NB is
*> the optimal blocksize for DSYTRF_AASEN.
*>
*> If LWORK = -1, then a workspace query is assumed; the routine
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
*> \date November 2016
*
*
* =========== DOCUMENTATION ===========
*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
-*> Download DSYTRF_AASEN + dependencies
-*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dsytrf_aasen.f">
-*> [TGZ]</a>
-*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dsytrf_aasen.f">
-*> [ZIP]</a>
-*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dsytrf_aasen.f">
+*> Download DSYTRF_AASEN + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dsytrf_aasen.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dsytrf_aasen.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dsytrf_aasen.f">
*> [TXT]</a>
-*> \endhtmlonly
+*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DSYTRF_AASEN( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )
-*
+*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER N, LDA, LWORK, INFO
*> triangular part of A is not referenced.
*>
*> On exit, the tridiagonal matrix is stored in the diagonals
-*> and the subdiagonals of A just below (or above) the diagonals,
+*> and the subdiagonals of A just below (or above) the diagonals,
*> and L is stored below (or above) the subdiaonals, when UPLO
*> is 'L' (or 'U').
*> \endverbatim
*> \param[out] IPIV
*> \verbatim
*> IPIV is INTEGER array, dimension (N)
-*> On exit, it contains the details of the interchanges, i.e.,
-*> the row and column k of A were interchanged with the
+*> On exit, it contains the details of the interchanges, i.e.,
+*> the row and column k of A were interchanged with the
*> row and column IPIV(k).
*> \endverbatim
*>
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
*> \date November 2016
*
*
J = 0
10 CONTINUE
- IF( J.GE.N )
+ IF( J.GE.N )
$ GO TO 20
*
* each step of the main loop
* J is the last column of the previous panel
* J1 is the first column of the current panel
* K1 identifies if the previous column of the panel has been
-* explicitly stored, e.g., K1=1 for the first panel, and
+* explicitly stored, e.g., K1=1 for the first panel, and
* K1=0 for the rest
*
J1 = J + 1
*
* Panel factorization
*
- CALL DLASYF_AASEN( UPLO, 2-K1, N-J, JB,
+ CALL DLASYF_AASEN( UPLO, 2-K1, N-J, JB,
$ A( MAX(1, J), J+1 ), LDA,
- $ IPIV( J+1 ), WORK, N, WORK( N*NB+1 ),
+ $ IPIV( J+1 ), WORK, N, WORK( N*NB+1 ),
$ IINFO )
IF( (IINFO.GT.0) .AND. (INFO.EQ.0) ) THEN
INFO = IINFO+J
- ENDIF
+ ENDIF
*
* Ajust IPIV and apply it back (J-th step picks (J+1)-th pivot)
*
DO J2 = J+2, MIN(N, J+JB+1)
IPIV( J2 ) = IPIV( J2 ) + J
IF( (J2.NE.IPIV(J2)) .AND. ((J1-K1).GT.2) ) THEN
- CALL DSWAP( J1-K1-2, A( 1, J2 ), 1,
+ CALL DSWAP( J1-K1-2, A( 1, J2 ), 1,
$ A( 1, IPIV(J2) ), 1 )
END IF
END DO
J = J + JB
*
* Trailing submatrix update, where
-* the row A(J1-1, J2-1:N) stores U(J1, J2+1:N) and
+* the row A(J1-1, J2-1:N) stores U(J1, J2+1:N) and
* WORK stores the current block of the auxiriarly matrix H
*
IF( J.LT.N ) THEN
*
ALPHA = A( J, J+1 )
A( J, J+1 ) = ONE
- CALL DCOPY( N-J, A( J-1, J+1 ), LDA,
+ CALL DCOPY( N-J, A( J-1, J+1 ), LDA,
$ WORK( (J+1-J1+1)+JB*N ), 1 )
CALL DSCAL( N-J, ALPHA, WORK( (J+1-J1+1)+JB*N ), 1 )
*
* K1 identifies if the previous column of the panel has been
-* explicitly stored, e.g., K1=1 and K2= 0 for the first panel,
+* explicitly stored, e.g., K1=1 and K2= 0 for the first panel,
* while K1=0 and K2=1 for the rest
*
IF( J1.GT.1 ) THEN
* Not first panel
*
K2 = 1
- ELSE
+ ELSE
*
* First panel
*
K2 = 0
*
-* First update skips the first column
+* First update skips the first column
*
JB = JB - 1
END IF
*
* Update off-diagonal block of J2-th block row with DGEMM
*
- CALL DGEMM( 'Transpose', 'Transpose',
+ CALL DGEMM( 'Transpose', 'Transpose',
$ NJ, N-J3+1, JB+1,
$ -ONE, A( J1-K2, J2 ), LDA,
$ WORK( J3-J1+1+K1*N ), N,
* Factorize A as L*D*L**T using the lower triangle of A
* .....................................................
*
-* copy first column A(1:N, 1) into H(1:N, 1)
+* copy first column A(1:N, 1) into H(1:N, 1)
* (stored in WORK(1:N))
*
CALL DCOPY( N, A( 1, 1 ), 1, WORK( 1 ), 1 )
*
J = 0
11 CONTINUE
- IF( J.GE.N )
+ IF( J.GE.N )
$ GO TO 20
*
* each step of the main loop
* J is the last column of the previous panel
* J1 is the first column of the current panel
* K1 identifies if the previous column of the panel has been
-* explicitly stored, e.g., K1=1 for the first panel, and
+* explicitly stored, e.g., K1=1 for the first panel, and
* K1=0 for the rest
*
J1 = J+1
*
* Panel factorization
*
- CALL DLASYF_AASEN( UPLO, 2-K1, N-J, JB,
+ CALL DLASYF_AASEN( UPLO, 2-K1, N-J, JB,
$ A( J+1, MAX(1, J) ), LDA,
$ IPIV( J+1 ), WORK, N, WORK( N*NB+1 ), IINFO)
IF( (IINFO.GT.0) .AND. (INFO.EQ.0) ) THEN
INFO = IINFO+J
- ENDIF
+ ENDIF
*
* Ajust IPIV and apply it back (J-th step picks (J+1)-th pivot)
*
DO J2 = J+2, MIN(N, J+JB+1)
IPIV( J2 ) = IPIV( J2 ) + J
IF( (J2.NE.IPIV(J2)) .AND. ((J1-K1).GT.2) ) THEN
- CALL DSWAP( J1-K1-2, A( J2, 1 ), LDA,
+ CALL DSWAP( J1-K1-2, A( J2, 1 ), LDA,
$ A( IPIV(J2), 1 ), LDA )
END IF
END DO
J = J + JB
*
* Trailing submatrix update, where
-* A(J2+1, J1-1) stores L(J2+1, J1) and
+* A(J2+1, J1-1) stores L(J2+1, J1) and
* WORK(J2+1, 1) stores H(J2+1, 1)
*
IF( J.LT.N ) THEN
*
ALPHA = A( J+1, J )
A( J+1, J ) = ONE
- CALL DCOPY( N-J, A( J+1, J-1 ), 1,
+ CALL DCOPY( N-J, A( J+1, J-1 ), 1,
$ WORK( (J+1-J1+1)+JB*N ), 1 )
CALL DSCAL( N-J, ALPHA, WORK( (J+1-J1+1)+JB*N ), 1 )
*
* K1 identifies if the previous column of the panel has been
-* explicitly stored, e.g., K1=1 and K2= 0 for the first panel,
+* explicitly stored, e.g., K1=1 and K2= 0 for the first panel,
* while K1=0 and K2=1 for the rest
*
IF( J1.GT.1 ) THEN
*
K2 = 0
*
-* First update skips the first column
+* First update skips the first column
*
JB = JB - 1
END IF
*
* Update off-diagonal block in J2-th block column with DGEMM
*
- CALL DGEMM( 'No transpose', 'Transpose',
+ CALL DGEMM( 'No transpose', 'Transpose',
$ N-J3+1, NJ, JB+1,
$ -ONE, WORK( J3-J1+1+K1*N ), N,
$ A( J2, J1-K2 ), LDA,
*
* =========== DOCUMENTATION ===========
*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DSYTRS_AASEN + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dsytrs_aasen.f">
-*> [TGZ]</a>
+*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dsytrs_aasen.f">
-*> [ZIP]</a>
+*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dsytrs_aasen.f">
*> [TXT]</a>
-*> \endhtmlonly
+*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DSYTRS_AASEN( UPLO, N, NRHS, A, LDA, IPIV, B, LDB,
* WORK, LWORK, INFO )
-*
+*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER N, NRHS, LDA, LDB, LWORK, INFO
* INTEGER IPIV( * )
* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), WORK( * )
* ..
-*
+*
*
*> \par Purpose:
* =============
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
*> \date November 2016
*
$ INFO)
*
* Compute (L**T \ B) -> B [ L**T \ (T \ (L \P**T * B) ) ]
-*
+*
CALL DTRSM( 'L', 'L', 'T', 'U', N-1, NRHS, ONE, A( 2, 1 ), LDA,
$ B( 2, 1 ), LDB)
*
*
* =========== DOCUMENTATION ===========
*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
-*> Download DTPQRT + dependencies
-*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dtplqt.f">
-*> [TGZ]</a>
-*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dtplqt.f">
-*> [ZIP]</a>
-*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dtplqt.f">
+*> Download DTPQRT + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dtplqt.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dtplqt.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dtplqt.f">
*> [TXT]</a>
-*> \endhtmlonly
+*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DTPLQT( M, N, L, MB, A, LDA, B, LDB, T, LDT, WORK,
* INFO )
-*
+*
* .. Scalar Arguments ..
* INTEGER INFO, LDA, LDB, LDT, N, M, L, MB
* ..
* .. Array Arguments ..
* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), T( LDT, * ), WORK( * )
* ..
-*
+*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
-*> DTPLQT computes a blocked LQ factorization of a real
-*> "triangular-pentagonal" matrix C, which is composed of a
-*> triangular block A and pentagonal block B, using the compact
+*> DTPLQT computes a blocked LQ factorization of a real
+*> "triangular-pentagonal" matrix C, which is composed of a
+*> triangular block A and pentagonal block B, using the compact
*> WY representation for Q.
*> \endverbatim
*
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix B, and the order of the
-*> triangular matrix A.
+*> triangular matrix A.
*> M >= 0.
*> \endverbatim
*>
*> \param[in,out] B
*> \verbatim
*> B is DOUBLE PRECISION array, dimension (LDB,N)
-*> On entry, the pentagonal M-by-N matrix B. The first N-L columns
+*> On entry, the pentagonal M-by-N matrix B. The first N-L columns
*> are rectangular, and the last L columns are lower trapezoidal.
*> On exit, B contains the pentagonal matrix V. See Further Details.
*> \endverbatim
*> The lower triangular block reflectors stored in compact form
*> as a sequence of upper triangular blocks. See Further Details.
*> \endverbatim
-*>
+*>
*> \param[in] LDT
*> \verbatim
*> LDT is INTEGER
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
*> \date November 2013
*
*>
*> \verbatim
*>
-*> The input matrix C is a M-by-(M+N) matrix
+*> The input matrix C is a M-by-(M+N) matrix
*>
*> C = [ A ] [ B ]
-*>
+*>
*>
*> where A is an lower triangular N-by-N matrix, and B is M-by-N pentagonal
*> matrix consisting of a M-by-(N-L) rectangular matrix B1 on left of a M-by-L
*> upper trapezoidal matrix B2:
-*> [ B ] = [ B1 ] [ B2 ]
+*> [ B ] = [ B1 ] [ B2 ]
*> [ B1 ] <- M-by-(N-L) rectangular
*> [ B2 ] <- M-by-L upper trapezoidal.
*>
*> The lower trapezoidal matrix B2 consists of the first L columns of a
-*> N-by-N lower triangular matrix, where 0 <= L <= MIN(M,N). If L=0,
-*> B is rectangular M-by-N; if M=L=N, B is lower triangular.
+*> N-by-N lower triangular matrix, where 0 <= L <= MIN(M,N). If L=0,
+*> B is rectangular M-by-N; if M=L=N, B is lower triangular.
*>
*> The matrix W stores the elementary reflectors H(i) in the i-th row
*> above the diagonal (of A) in the M-by-(M+N) input matrix C
-*> [ C ] = [ A ] [ B ]
+*> [ C ] = [ A ] [ B ]
*> [ A ] <- lower triangular N-by-N
*> [ B ] <- M-by-N pentagonal
*>
*> so that W can be represented as
-*> [ W ] = [ I ] [ V ]
+*> [ W ] = [ I ] [ V ]
*> [ I ] <- identity, N-by-N
*> [ V ] <- M-by-N, same form as B.
*>
*> Thus, all of information needed for W is contained on exit in B, which
-*> we call V above. Note that V has the same form as B; that is,
-*> [ V ] = [ V1 ] [ V2 ]
+*> we call V above. Note that V has the same form as B; that is,
+*> [ V ] = [ V1 ] [ V2 ]
*> [ V1 ] <- M-by-(N-L) rectangular
*> [ V2 ] <- M-by-L lower trapezoidal.
*>
-*> The rows of V represent the vectors which define the H(i)'s.
+*> The rows of V represent the vectors which define the H(i)'s.
*>
*> The number of blocks is B = ceiling(M/MB), where each
-*> block is of order MB except for the last block, which is of order
+*> block is of order MB except for the last block, which is of order
*> IB = M - (M-1)*MB. For each of the B blocks, a upper triangular block
-*> reflector factor is computed: T1, T2, ..., TB. The MB-by-MB (and IB-by-IB
+*> reflector factor is computed: T1, T2, ..., TB. The MB-by-MB (and IB-by-IB
*> for the last block) T's are stored in the MB-by-N matrix T as
*>
*> T = [T1 T2 ... TB].
IF( M.EQ.0 .OR. N.EQ.0 ) RETURN
*
DO I = 1, M, MB
-*
+*
* Compute the QR factorization of the current block
*
IB = MIN( M-I+1, MB )
LB = NB-N+L-I+1
END IF
*
- CALL DTPLQT2( IB, NB, LB, A(I,I), LDA, B( I, 1 ), LDB,
+ CALL DTPLQT2( IB, NB, LB, A(I,I), LDA, B( I, 1 ), LDB,
$ T(1, I ), LDT, IINFO )
*
* Update by applying H**T to B(I+IB:M,:) from the right
*
IF( I+IB.LE.M ) THEN
CALL DTPRFB( 'R', 'N', 'F', 'R', M-I-IB+1, NB, IB, LB,
- $ B( I, 1 ), LDB, T( 1, I ), LDT,
- $ A( I+IB, I ), LDA, B( I+IB, 1 ), LDB,
+ $ B( I, 1 ), LDB, T( 1, I ), LDT,
+ $ A( I+IB, I ), LDA, B( I+IB, 1 ), LDB,
$ WORK, M-I-IB+1)
END IF
END DO
RETURN
-*
+*
* End of DTPLQT
*
END
*
* =========== DOCUMENTATION ===========
*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
-*> Download DTPLQT2 + dependencies
-*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dtplqt2.f">
-*> [TGZ]</a>
-*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dtplqt2.f">
-*> [ZIP]</a>
-*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dtplqt2.f">
+*> Download DTPLQT2 + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dtplqt2.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dtplqt2.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dtplqt2.f">
*> [TXT]</a>
-*> \endhtmlonly
+*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DTPLQT2( M, N, L, A, LDA, B, LDB, T, LDT, INFO )
-*
+*
* .. Scalar Arguments ..
* INTEGER INFO, LDA, LDB, LDT, N, M, L
* ..
* .. Array Arguments ..
* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), T( LDT, * )
* ..
-*
+*
*
*> \par Purpose:
* =============
*> \verbatim
*>
*> DTPLQT2 computes a LQ a factorization of a real "triangular-pentagonal"
-*> matrix C, which is composed of a triangular block A and pentagonal block B,
+*> matrix C, which is composed of a triangular block A and pentagonal block B,
*> using the compact WY representation for Q.
*> \endverbatim
*
*> \param[in] M
*> \verbatim
*> M is INTEGER
-*> The total number of rows of the matrix B.
+*> The total number of rows of the matrix B.
*> M >= 0.
*> \endverbatim
*>
*> \param[in] L
*> \verbatim
*> L is INTEGER
-*> The number of rows of the lower trapezoidal part of B.
+*> The number of rows of the lower trapezoidal part of B.
*> MIN(M,N) >= L >= 0. See Further Details.
*> \endverbatim
*>
*> \param[in,out] B
*> \verbatim
*> B is DOUBLE PRECISION array, dimension (LDB,N)
-*> On entry, the pentagonal M-by-N matrix B. The first N-L columns
+*> On entry, the pentagonal M-by-N matrix B. The first N-L columns
*> are rectangular, and the last L columns are lower trapezoidal.
*> On exit, B contains the pentagonal matrix V. See Further Details.
*> \endverbatim
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
*> \date September 2012
*
*>
*> \verbatim
*>
-*> The input matrix C is a M-by-(M+N) matrix
+*> The input matrix C is a M-by-(M+N) matrix
*>
*> C = [ A ][ B ]
-*>
+*>
*>
*> where A is an lower triangular N-by-N matrix, and B is M-by-N pentagonal
*> matrix consisting of a M-by-(N-L) rectangular matrix B1 left of a M-by-L
*> [ B2 ] <- M-by-L lower trapezoidal.
*>
*> The lower trapezoidal matrix B2 consists of the first L columns of a
-*> N-by-N lower triangular matrix, where 0 <= L <= MIN(M,N). If L=0,
-*> B is rectangular M-by-N; if M=L=N, B is lower triangular.
+*> N-by-N lower triangular matrix, where 0 <= L <= MIN(M,N). If L=0,
+*> B is rectangular M-by-N; if M=L=N, B is lower triangular.
*>
*> The matrix W stores the elementary reflectors H(i) in the i-th row
*> above the diagonal (of A) in the M-by-(M+N) input matrix C
*>
*> so that W can be represented as
*>
-*> W = [ I ][ V ]
+*> W = [ I ][ V ]
*> [ I ] <- identity, N-by-N
*> [ V ] <- M-by-N, same form as B.
*>
*> Thus, all of information needed for W is contained on exit in B, which
-*> we call V above. Note that V has the same form as B; that is,
+*> we call V above. Note that V has the same form as B; that is,
*>
-*> W = [ V1 ][ V2 ]
+*> W = [ V1 ][ V2 ]
*> [ V1 ] <- M-by-(N-L) rectangular
*> [ V2 ] <- M-by-L lower trapezoidal.
*>
-*> The rows of V represent the vectors which define the H(i)'s.
+*> The rows of V represent the vectors which define the H(i)'s.
*> The (M+N)-by-(M+N) block reflector H is then given by
*>
*> H = I - W**T * T * W
* Quick return if possible
*
IF( N.EQ.0 .OR. M.EQ.0 ) RETURN
-*
+*
DO I = 1, M
*
* Generate elementary reflector H(I) to annihilate B(I,:)
DO J = 1, M-I
T( M, J ) = (A( I+J, I ))
END DO
- CALL DGEMV( 'N', M-I, P, ONE, B( I+1, 1 ), LDB,
+ CALL DGEMV( 'N', M-I, P, ONE, B( I+1, 1 ), LDB,
$ B( I, 1 ), LDB, ONE, T( M, 1 ), LDT )
*
* C(I+1:M,I:N) = C(I+1:M,I:N) + alpha * C(I,I:N)*W(M-1:1)^H
*
- ALPHA = -(T( 1, I ))
+ ALPHA = -(T( 1, I ))
DO J = 1, M-I
A( I+J, I ) = A( I+J, I ) + ALPHA*(T( M, J ))
END DO
*
* Rectangular part of B2
*
- CALL DGEMV( 'N', I-1-P, L, ALPHA, B( MP, NP ), LDB,
+ CALL DGEMV( 'N', I-1-P, L, ALPHA, B( MP, NP ), LDB,
$ B( I, NP ), LDB, ZERO, T( I,MP ), LDT )
*
* B1
*
- CALL DGEMV( 'N', I-1, N-L, ALPHA, B, LDB, B( I, 1 ), LDB,
- $ ONE, T( I, 1 ), LDT )
+ CALL DGEMV( 'N', I-1, N-L, ALPHA, B, LDB, B( I, 1 ), LDB,
+ $ ONE, T( I, 1 ), LDT )
*
* T(1:I-1,I) := T(1:I-1,1:I-1) * T(I,1:I-1)
*
T(J,I)= ZERO
END DO
END DO
-
+
*
* End of DTPLQT2
*
*
* =========== DOCUMENTATION ===========
*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
-*> Download DTPMQRT + dependencies
-*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dtpmlqt.f">
-*> [TGZ]</a>
-*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dtpmlqt.f">
-*> [ZIP]</a>
-*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dtpmlqt.f">
+*> Download DTPMQRT + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dtpmlqt.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dtpmlqt.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dtpmlqt.f">
*> [TXT]</a>
-*> \endhtmlonly
+*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DTPMLQT( SIDE, TRANS, M, N, K, L, MB, V, LDV, T, LDT,
* A, LDA, B, LDB, WORK, INFO )
-*
+*
* .. Scalar Arguments ..
* CHARACTER SIDE, TRANS
* INTEGER INFO, K, LDV, LDA, LDB, M, N, L, MB, LDT
* ..
* .. Array Arguments ..
-* DOUBLE PRECISION V( LDV, * ), A( LDA, * ), B( LDB, * ),
+* DOUBLE PRECISION V( LDV, * ), A( LDA, * ), B( LDB, * ),
* $ T( LDT, * ), WORK( * )
* ..
-*
+*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
-*> DTPMQRT applies a real orthogonal matrix Q obtained from a
+*> DTPMQRT applies a real orthogonal matrix Q obtained from a
*> "triangular-pentagonal" real block reflector H to a general
*> real matrix C, which consists of two blocks A and B.
*> \endverbatim
*> N is INTEGER
*> The number of columns of the matrix B. N >= 0.
*> \endverbatim
-*>
+*>
*> \param[in] K
*> \verbatim
*> K is INTEGER
*> \param[in] L
*> \verbatim
*> L is INTEGER
-*> The order of the trapezoidal part of V.
+*> The order of the trapezoidal part of V.
*> K >= L >= 0. See Further Details.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is DOUBLE PRECISION array, dimension
-*> (LDA,N) if SIDE = 'L' or
+*> (LDA,N) if SIDE = 'L' or
*> (LDA,K) if SIDE = 'R'
*> On entry, the K-by-N or M-by-K matrix A.
-*> On exit, A is overwritten by the corresponding block of
+*> On exit, A is overwritten by the corresponding block of
*> Q*C or Q**T*C or C*Q or C*Q**T. See Further Details.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
-*> The leading dimension of the array A.
+*> The leading dimension of the array A.
*> If SIDE = 'L', LDC >= max(1,K);
-*> If SIDE = 'R', LDC >= max(1,M).
+*> If SIDE = 'R', LDC >= max(1,M).
*> \endverbatim
*>
*> \param[in,out] B
*> \param[in] LDB
*> \verbatim
*> LDB is INTEGER
-*> The leading dimension of the array B.
+*> The leading dimension of the array B.
*> LDB >= max(1,M).
*> \endverbatim
*>
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
*> \date November 2015
*
*> \verbatim
*>
*> The columns of the pentagonal matrix V contain the elementary reflectors
-*> H(1), H(2), ..., H(K); V is composed of a rectangular block V1 and a
+*> H(1), H(2), ..., H(K); V is composed of a rectangular block V1 and a
*> trapezoidal block V2:
*>
*> V = [V1] [V2].
-*>
*>
-*> The size of the trapezoidal block V2 is determined by the parameter L,
+*>
+*> The size of the trapezoidal block V2 is determined by the parameter L,
*> where 0 <= L <= K; V2 is lower trapezoidal, consisting of the first L
*> rows of a K-by-K upper triangular matrix. If L=K, V2 is lower triangular;
*> if L=0, there is no trapezoidal block, hence V = V1 is rectangular.
*>
-*> If SIDE = 'L': C = [A] where A is K-by-N, B is M-by-N and V is K-by-M.
-*> [B]
-*>
+*> If SIDE = 'L': C = [A] where A is K-by-N, B is M-by-N and V is K-by-M.
+*> [B]
+*>
*> If SIDE = 'R': C = [A B] where A is M-by-K, B is M-by-N and V is K-by-N.
*>
*> The real orthogonal matrix Q is formed from V and T.
INTEGER INFO, K, LDV, LDA, LDB, M, N, L, MB, LDT
* ..
* .. Array Arguments ..
- DOUBLE PRECISION V( LDV, * ), A( LDA, * ), B( LDB, * ),
+ DOUBLE PRECISION V( LDV, * ), A( LDA, * ), B( LDB, * ),
$ T( LDT, * ), WORK( * )
* ..
*
RIGHT = LSAME( SIDE, 'R' )
TRAN = LSAME( TRANS, 'T' )
NOTRAN = LSAME( TRANS, 'N' )
-*
+*
IF ( LEFT ) THEN
LDAQ = MAX( 1, K )
ELSE IF ( RIGHT ) THEN
ELSE IF( K.LT.0 ) THEN
INFO = -5
ELSE IF( L.LT.0 .OR. L.GT.K ) THEN
- INFO = -6
+ INFO = -6
ELSE IF( MB.LT.1 .OR. (MB.GT.K .AND. K.GT.0) ) THEN
INFO = -7
ELSE IF( LDV.LT.K ) THEN
ELSE
LB = 0
END IF
- CALL DTPRFB( 'L', 'T', 'F', 'R', NB, N, IB, LB,
- $ V( I, 1 ), LDV, T( 1, I ), LDT,
+ CALL DTPRFB( 'L', 'T', 'F', 'R', NB, N, IB, LB,
+ $ V( I, 1 ), LDV, T( 1, I ), LDT,
$ A( I, 1 ), LDA, B, LDB, WORK, IB )
END DO
-*
+*
ELSE IF( RIGHT .AND. TRAN ) THEN
*
DO I = 1, K, MB
ELSE
LB = NB-N+L-I+1
END IF
- CALL DTPRFB( 'R', 'N', 'F', 'R', M, NB, IB, LB,
- $ V( I, 1 ), LDV, T( 1, I ), LDT,
+ CALL DTPRFB( 'R', 'N', 'F', 'R', M, NB, IB, LB,
+ $ V( I, 1 ), LDV, T( 1, I ), LDT,
$ A( 1, I ), LDA, B, LDB, WORK, M )
END DO
*
*
KF = ((K-1)/MB)*MB+1
DO I = KF, 1, -MB
- IB = MIN( MB, K-I+1 )
+ IB = MIN( MB, K-I+1 )
NB = MIN( M-L+I+IB-1, M )
IF( I.GE.L ) THEN
LB = 0
ELSE
LB = 0
- END IF
+ END IF
CALL DTPRFB( 'L', 'N', 'F', 'R', NB, N, IB, LB,
- $ V( I, 1 ), LDV, T( 1, I ), LDT,
+ $ V( I, 1 ), LDV, T( 1, I ), LDT,
$ A( I, 1 ), LDA, B, LDB, WORK, IB )
END DO
*
*
KF = ((K-1)/MB)*MB+1
DO I = KF, 1, -MB
- IB = MIN( MB, K-I+1 )
+ IB = MIN( MB, K-I+1 )
NB = MIN( N-L+I+IB-1, N )
IF( I.GE.L ) THEN
LB = 0
LB = NB-N+L-I+1
END IF
CALL DTPRFB( 'R', 'T', 'F', 'R', M, NB, IB, LB,
- $ V( I, 1 ), LDV, T( 1, I ), LDT,
+ $ V( I, 1 ), LDV, T( 1, I ), LDT,
$ A( 1, I ), LDA, B, LDB, WORK, M )
END DO
*
NB = N1
ELSE
NB = 32768/N2
- END IF
+ END IF
END IF
ELSE
IF( SNAME ) THEN
NB = N1
ELSE
NB = 32768/N2
- END IF
+ END IF
END IF
ELSE
IF( SNAME ) THEN
-*
+*
* Definition:
* ===========
*
-* SUBROUTINE SGELQ( M, N, A, LDA, WORK1, LWORK1, WORK2, LWORK2,
+* SUBROUTINE SGELQ( M, N, A, LDA, WORK1, LWORK1, WORK2, LWORK2,
* INFO)
-*
+*
* .. Scalar Arguments ..
* INTEGER INFO, LDA, M, N, LWORK1, LWORK2
* ..
* .. Array Arguments ..
* REAL A( LDA, * ), WORK1( * ), WORK2( * )
* ..
-*
+*
*
*> \par Purpose:
* =============
*>
*> \verbatim
-*>
-*> SGELQ computes an LQ factorization of an M-by-N matrix A,
-*> using SLASWLQ when A is short and wide
-*> (N sufficiently greater than M), and otherwise SGELQT:
+*>
+*> SGELQ computes an LQ factorization of an M-by-N matrix A,
+*> using SLASWLQ when A is short and wide
+*> (N sufficiently greater than M), and otherwise SGELQT:
*> A = L * Q .
*> \endverbatim
*
*> \verbatim
*> A is REAL array, dimension (LDA,N)
*> On entry, the M-by-N matrix A.
-*> On exit, the elements on and below the diagonal of the array
-*> contain the M-by-min(M,N) lower trapezoidal matrix L
+*> On exit, the elements on and below the diagonal of the array
+*> contain the M-by-min(M,N) lower trapezoidal matrix L
*> (L is lower triangular if M <= N);
-*> the elements above the diagonal are the rows of
+*> the elements above the diagonal are the rows of
*> blocked V representing Q (see Further Details).
*> \endverbatim
*>
*> \verbatim
*> WORK1 is REAL array, dimension (MAX(1,LWORK1))
*> WORK1 contains part of the data structure used to store Q.
-*> WORK1(1): algorithm type = 1, to indicate output from
+*> WORK1(1): algorithm type = 1, to indicate output from
*> SLASWLQ or SGELQT
*> WORK1(2): optimum size of WORK1
*> WORK1(3): minimum size of WORK1
*> WORK1(4): horizontal block size
*> WORK1(5): vertical block size
-*> WORK1(6:LWORK1): data structure needed for Q, computed by
+*> WORK1(6:LWORK1): data structure needed for Q, computed by
*> SLASWLQ or SGELQT
*> \endverbatim
*>
*> \verbatim
*> LWORK1 is INTEGER
*> The dimension of the array WORK1.
-*> If LWORK1 = -1, then a query is assumed. In this case the
+*> If LWORK1 = -1, then a query is assumed. In this case the
*> routine calculates the optimal size of WORK1 and
-*> returns this value in WORK1(2), and calculates the minimum
-*> size of WORK1 and returns this value in WORK1(3).
-*> No error message related to LWORK1 is issued by XERBLA when
+*> returns this value in WORK1(2), and calculates the minimum
+*> size of WORK1 and returns this value in WORK1(3).
+*> No error message related to LWORK1 is issued by XERBLA when
*> LWORK1 = -1.
*> \endverbatim
*>
*> \param[out] WORK2
*> \verbatim
*> (workspace) REAL array, dimension (MAX(1,LWORK2))
-*>
+*>
*> \endverbatim
*> \param[in] LWORK2
*> \verbatim
*> LWORK2 is INTEGER
*> The dimension of the array WORK2.
*> If LWORK2 = -1, then a query is assumed. In this case the
-*> routine calculates the optimal size of WORK2 and
+*> routine calculates the optimal size of WORK2 and
*> returns this value in WORK2(1), and calculates the minimum
*> size of WORK2 and returns this value in WORK2(2).
*> No error message related to LWORK2 is issued by XERBLA when
*> Depending on the matrix dimensions M and N, and row and column
*> block sizes MB and NB returned by ILAENV, GELQ will use either
*> LASWLQ(if the matrix is short-and-wide) or GELQT to compute
-*> the LQ decomposition.
+*> the LQ decomposition.
*> The output of LASWLQ or GELQT representing Q is stored in A and in
-*> array WORK1(6:LWORK1) for later use.
-*> WORK1(2:5) contains the matrix dimensions M,N and block sizes MB, NB
-*> which are needed to interpret A and WORK1(6:LWORK1) for later use.
-*> WORK1(1)=1 indicates that the code needed to take WORK1(2:5) and
+*> array WORK1(6:LWORK1) for later use.
+*> WORK1(2:5) contains the matrix dimensions M,N and block sizes MB, NB
+*> which are needed to interpret A and WORK1(6:LWORK1) for later use.
+*> WORK1(1)=1 indicates that the code needed to take WORK1(2:5) and
*> decide whether LASWLQ or GELQT was used is the same as used below in
-*> GELQ. For a detailed description of A and WORK1(6:LWORK1), see
+*> GELQ. For a detailed description of A and WORK1(6:LWORK1), see
*> Further Details in LASWLQ or GELQT.
*> \endverbatim
*>
*>
* =====================================================================
- SUBROUTINE SGELQ( M, N, A, LDA, WORK1, LWORK1, WORK2, LWORK2,
+ SUBROUTINE SGELQ( M, N, A, LDA, WORK1, LWORK1, WORK2, LWORK2,
$ INFO)
*
* -- LAPACK computational routine (version 3.5.0) --
*
LQUERY = ( LWORK1.EQ.-1 .OR. LWORK2.EQ.-1 )
*
-* Determine the block size
-*
+* Determine the block size
+*
IF ( MIN(M,N).GT.0 ) THEN
MB = ILAENV( 1, 'SGELQ ', ' ', M, N, 1, -1)
NB = ILAENV( 1, 'SGELQ ', ' ', M, N, 2, -1)
END IF
*
* Determine if the workspace size satisfies minimum size
-*
+*
LMINWS = .FALSE.
IF((LWORK1.LT.MAX(1,MB*M*NBLCKS+5)
$ .OR.(LWORK2.LT.MB*M)).AND.(LWORK2.GE.M).AND.(LWORK1.GE.M+5)
IF (LWORK1.LT.MAX(1,MB*M*NBLCKS+5)) THEN
LMINWS = .TRUE.
MB = 1
- END IF
+ END IF
IF (LWORK1.LT.MAX(1,M*NBLCKS+5)) THEN
LMINWS = .TRUE.
- NB = N
+ NB = N
END IF
IF (LWORK2.LT.MB*M) THEN
LMINWS = .TRUE.
INFO = -2
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -4
- ELSE IF( LWORK1.LT.MAX( 1, MB*M*NBLCKS+5 )
+ ELSE IF( LWORK1.LT.MAX( 1, MB*M*NBLCKS+5 )
$ .AND.(.NOT.LQUERY).AND. (.NOT.LMINWS)) THEN
INFO = -6
ELSE IF( (LWORK2.LT.MAX(1,M*MB)).AND.(.NOT.LQUERY)
$ .AND.(.NOT.LMINWS) ) THEN
- INFO = -8
- END IF
+ INFO = -8
+ END IF
*
IF( INFO.EQ.0) THEN
WORK1(1) = 1
*
IF((N.LE.M).OR.(NB.LE.M).OR.(NB.GE.N)) THEN
CALL SGELQT( M, N, MB, A, LDA, WORK1(6), MB, WORK2, INFO)
- ELSE
- CALL SLASWLQ( M, N, MB, NB, A, LDA, WORK1(6), MB, WORK2,
+ ELSE
+ CALL SLASWLQ( M, N, MB, NB, A, LDA, WORK1(6), MB, WORK2,
$ LWORK2, INFO)
END IF
RETURN
-*
+*
* End of SGELQ
*
- END
\ No newline at end of file
+ END
* ===========
*
* SUBROUTINE SGELQT( M, N, MB, A, LDA, T, LDT, WORK, INFO )
-*
+*
* .. Scalar Arguments ..
* INTEGER INFO, LDA, LDT, M, N, MB
* ..
* .. Array Arguments ..
* REAL A( LDA, * ), T( LDT, * ), WORK( * )
* ..
-*
+*
*
*> \par Purpose:
* =============
*> \verbatim
*>
*> DGELQT computes a blocked LQ factorization of a real M-by-N matrix A
-*> using the compact WY representation of Q.
+*> using the compact WY representation of Q.
*> \endverbatim
*
* Arguments:
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
*> \date November 2013
*
*> V = ( 1 v1 v1 v1 v1 )
*> ( 1 v2 v2 v2 )
*> ( 1 v3 v3 )
-*>
+*>
*>
*> where the vi's represent the vectors which define H(i), which are returned
-*> in the matrix A. The 1's along the diagonal of V are not stored in A.
+*> in the matrix A. The 1's along the diagonal of V are not stored in A.
*> Let K=MIN(M,N). The number of blocks is B = ceiling(K/NB), where each
-*> block is of order NB except for the last block, which is of order
+*> block is of order NB except for the last block, which is of order
*> IB = K - (B-1)*NB. For each of the B blocks, a upper triangular block
-*> reflector factor is computed: T1, T2, ..., TB. The NB-by-NB (and IB-by-IB
+*> reflector factor is computed: T1, T2, ..., TB. The NB-by-NB (and IB-by-IB
*> for the last block) T's are stored in the NB-by-N matrix T as
*>
*> T = (T1 T2 ... TB).
*
DO I = 1, K, MB
IB = MIN( K-I+1, MB )
-*
+*
* Compute the LQ factorization of the current block A(I:M,I:I+IB-1)
-*
+*
CALL SGELQT3( IB, N-I+1, A(I,I), LDA, T(1,I), LDT, IINFO )
IF( I+IB.LE.M ) THEN
*
* Update by applying H**T to A(I:M,I+IB:N) from the right
*
CALL SLARFB( 'R', 'N', 'F', 'R', M-I-IB+1, N-I+1, IB,
- $ A( I, I ), LDA, T( 1, I ), LDT,
+ $ A( I, I ), LDA, T( 1, I ), LDT,
$ A( I+IB, I ), LDA, WORK , M-I-IB+1 )
END IF
END DO
RETURN
-*
+*
* End of SGELQT
*
END
* ===========
*
* RECURSIVE SUBROUTINE SGELQT3( M, N, A, LDA, T, LDT, INFO )
-*
+*
* .. Scalar Arguments ..
* INTEGER INFO, LDA, M, N, LDT
* ..
* .. Array Arguments ..
* REAL A( LDA, * ), T( LDT, * )
* ..
-*
+*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
-*> DGELQT3 recursively computes a LQ factorization of a real M-by-N
-*> matrix A, using the compact WY representation of Q.
+*> DGELQT3 recursively computes a LQ factorization of a real M-by-N
+*> matrix A, using the compact WY representation of Q.
*>
-*> Based on the algorithm of Elmroth and Gustavson,
+*> Based on the algorithm of Elmroth and Gustavson,
*> IBM J. Res. Develop. Vol 44 No. 4 July 2000.
*> \endverbatim
*
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
*> \date September 2012
*
*> V = ( 1 v1 v1 v1 v1 )
*> ( 1 v2 v2 v2 )
*> ( 1 v3 v3 v3 )
-*>
+*>
*>
*> where the vi's represent the vectors which define H(i), which are returned
*> in the matrix A. The 1's along the diagonal of V are not stored in A. The
* Compute Householder transform when N=1
*
CALL SLARFG( N, A, A( 1, MIN( 2, N ) ), LDA, T )
-*
+*
ELSE
*
* Otherwise, split A into blocks...
T( I+M1, J ) = A( I+M1, J )
END DO
END DO
- CALL STRMM( 'R', 'U', 'T', 'U', M2, M1, ONE,
+ CALL STRMM( 'R', 'U', 'T', 'U', M2, M1, ONE,
& A, LDA, T( I1, 1 ), LDT )
*
CALL SGEMM( 'N', 'T', M2, M1, N-M1, ONE, A( I1, I1 ), LDA,
CALL STRMM( 'R', 'U', 'N', 'N', M2, M1, ONE,
& T, LDT, T( I1, 1 ), LDT )
*
- CALL SGEMM( 'N', 'N', M2, N-M1, M1, -ONE, T( I1, 1 ), LDT,
+ CALL SGEMM( 'N', 'N', M2, N-M1, M1, -ONE, T( I1, 1 ), LDT,
& A( 1, I1 ), LDA, ONE, A( I1, I1 ), LDA )
*
CALL STRMM( 'R', 'U', 'N', 'U', M2, M1 , ONE,
*
* Compute A(J1:M,J1:N) <- (Y2,R2,T2) where Q2 = I - Y2 T2 Y2^H
*
- CALL SGELQT3( M2, N-M1, A( I1, I1 ), LDA,
+ CALL SGELQT3( M2, N-M1, A( I1, I1 ), LDA,
& T( I1, I1 ), LDT, IINFO )
*
* Compute T3 = T(J1:N1,1:N) = -T1 Y1^H Y2 T2
CALL SGEMM( 'N', 'T', M1, M2, N-M, ONE, A( 1, J1 ), LDA,
& A( I1, J1 ), LDA, ONE, T( 1, I1 ), LDT )
*
- CALL STRMM( 'L', 'U', 'N', 'N', M1, M2, -ONE, T, LDT,
+ CALL STRMM( 'L', 'U', 'N', 'N', M1, M2, -ONE, T, LDT,
& T( 1, I1 ), LDT )
*
- CALL STRMM( 'R', 'U', 'N', 'N', M1, M2, ONE,
+ CALL STRMM( 'R', 'U', 'N', 'N', M1, M2, ONE,
& T( I1, I1 ), LDT, T( 1, I1 ), LDT )
*
-*
+*
*
* Y = (Y1,Y2); L = [ L1 0 ]; T = [T1 T3]
* [ A(1:N1,J1:N) L2 ] [ 0 T2]
-*
+*
* Definition:
* ===========
*
-* SUBROUTINE SGEMLQ( SIDE, TRANS, M, N, K, A, LDA, WORK1,
+* SUBROUTINE SGEMLQ( SIDE, TRANS, M, N, K, A, LDA, WORK1,
* $ LWORK1, C, LDC, WORK2, LWORK2, INFO )
*
*
* =============
*>
*> \verbatim
-*>
+*>
*> DGEMLQ overwrites the general real M-by-N matrix C with
*>
-*>
+*>
*> SIDE = 'L' SIDE = 'R'
*> TRANS = 'N': Q * C C * Q
*> TRANS = 'T': Q**T * C C * Q**T
-*> where Q is a real orthogonal matrix defined as the product
-*> of blocked elementary reflectors computed by short wide LQ
+*> where Q is a real orthogonal matrix defined as the product
+*> of blocked elementary reflectors computed by short wide LQ
*> factorization (DGELQ)
*> \endverbatim
*
*> The number of elementary reflectors whose product defines
*> the matrix Q.
*> M >= K >= 0;
-*>
+*>
*> \endverbatim
*>
*> \param[in,out] A
*> \param[out] WORK2
*> \verbatim
*> (workspace) REAL array, dimension (MAX(1,LWORK2))
-*>
+*>
*> \endverbatim
*> \param[in] LWORK2
*> \verbatim
*> LWORK2 is INTEGER
-*> The dimension of the array WORK2.
+*> The dimension of the array WORK2.
*> If LWORK2 = -1, then a workspace query is assumed; the routine
*> only calculates the optimal size of the WORK2 array, returns
-*> this value as the third entry of the WORK2 array (WORK2(1)),
+*> this value as the third entry of the WORK2 array (WORK2(1)),
*> and no error message related to LWORK2 is issued by XERBLA.
*>
*> \endverbatim
*> Depending on the matrix dimensions M and N, and row and column
*> block sizes MB and NB returned by ILAENV, GELQ will use either
*> LASWLQ(if the matrix is short-and-wide) or GELQT to compute
-*> the LQ decomposition.
+*> the LQ decomposition.
*> The output of LASWLQ or GELQT representing Q is stored in A and in
-*> array WORK1(6:LWORK1) for later use.
-*> WORK1(2:5) contains the matrix dimensions M,N and block sizes MB, NB
-*> which are needed to interpret A and WORK1(6:LWORK1) for later use.
-*> WORK1(1)=1 indicates that the code needed to take WORK1(2:5) and
+*> array WORK1(6:LWORK1) for later use.
+*> WORK1(2:5) contains the matrix dimensions M,N and block sizes MB, NB
+*> which are needed to interpret A and WORK1(6:LWORK1) for later use.
+*> WORK1(1)=1 indicates that the code needed to take WORK1(2:5) and
*> decide whether LASWLQ or GELQT was used is the same as used below in
-*> GELQ. For a detailed description of A and WORK1(6:LWORK1), see
+*> GELQ. For a detailed description of A and WORK1(6:LWORK1), see
*> Further Details in LASWLQ or GELQT.
*> \endverbatim
*>
* =====================================================================
- SUBROUTINE SGEMLQ( SIDE, TRANS, M, N, K, A, LDA, WORK1, LWORK1,
+ SUBROUTINE SGEMLQ( SIDE, TRANS, M, N, K, A, LDA, WORK1, LWORK1,
$ C, LDC, WORK2, LWORK2, INFO )
*
* -- LAPACK computational routine (version 3.5.0) --
*
IF( MIN(M,N,K).EQ.0 ) THEN
RETURN
- END IF
+ END IF
*
IF((LEFT.AND.M.LE.K).OR.(RIGHT.AND.N.LE.K).OR.(NB.LE.K).OR.
$ (NB.GE.MAX(M,N,K))) THEN
- CALL SGEMLQT( SIDE, TRANS, M, N, K, MB, A, LDA,
- $ WORK1(6), MB, C, LDC, WORK2, INFO)
+ CALL SGEMLQT( SIDE, TRANS, M, N, K, MB, A, LDA,
+ $ WORK1(6), MB, C, LDC, WORK2, INFO)
ELSE
CALL SLAMSWLQ( SIDE, TRANS, M, N, K, MB, NB, A, LDA, WORK1(6),
$ MB, C, LDC, WORK2, LWORK2, INFO )
*
* End of SGEMLQ
*
- END
\ No newline at end of file
+ END
* Definition:
* ===========
*
-* SUBROUTINE SGEMLQT( SIDE, TRANS, M, N, K, MB, V, LDV, T, LDT,
+* SUBROUTINE SGEMLQT( SIDE, TRANS, M, N, K, MB, V, LDV, T, LDT,
* C, LDC, WORK, INFO )
-*
+*
* .. Scalar Arguments ..
* CHARACTER SIDE, TRANS
* INTEGER INFO, K, LDV, LDC, M, N, MB, LDT
* .. Array Arguments ..
* REAL V( LDV, * ), C( LDC, * ), T( LDT, * ), WORK( * )
* ..
-*
+*
*
*> \par Purpose:
* =============
*>
*> Q = H(1) H(2) . . . H(K) = I - V T V**T
*>
-*> generated using the compact WY representation as returned by DGELQT.
+*> generated using the compact WY representation as returned by DGELQT.
*>
*> Q is of order M if SIDE = 'L' and of order N if SIDE = 'R'.
*> \endverbatim
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
*> \date November 2013
*
*> \ingroup doubleGEcomputational
*
* =====================================================================
- SUBROUTINE SGEMLQT( SIDE, TRANS, M, N, K, MB, V, LDV, T, LDT,
+ SUBROUTINE SGEMLQT( SIDE, TRANS, M, N, K, MB, V, LDV, T, LDT,
$ C, LDC, WORK, INFO )
*
* -- LAPACK computational routine (version 3.5.0) --
RIGHT = LSAME( SIDE, 'R' )
TRAN = LSAME( TRANS, 'T' )
NOTRAN = LSAME( TRANS, 'N' )
-*
+*
IF( LEFT ) THEN
LDWORK = MAX( 1, N )
ELSE IF ( RIGHT ) THEN
*
DO I = 1, K, MB
IB = MIN( MB, K-I+1 )
- CALL SLARFB( 'L', 'T', 'F', 'R', M-I+1, N, IB,
- $ V( I, I ), LDV, T( 1, I ), LDT,
+ CALL SLARFB( 'L', 'T', 'F', 'R', M-I+1, N, IB,
+ $ V( I, I ), LDV, T( 1, I ), LDT,
$ C( I, 1 ), LDC, WORK, LDWORK )
END DO
-*
+*
ELSE IF( RIGHT .AND. TRAN ) THEN
*
DO I = 1, K, MB
IB = MIN( MB, K-I+1 )
- CALL SLARFB( 'R', 'N', 'F', 'R', M, N-I+1, IB,
- $ V( I, I ), LDV, T( 1, I ), LDT,
+ CALL SLARFB( 'R', 'N', 'F', 'R', M, N-I+1, IB,
+ $ V( I, I ), LDV, T( 1, I ), LDT,
$ C( 1, I ), LDC, WORK, LDWORK )
END DO
*
*
KF = ((K-1)/MB)*MB+1
DO I = KF, 1, -MB
- IB = MIN( MB, K-I+1 )
- CALL SLARFB( 'L', 'N', 'F', 'R', M-I+1, N, IB,
- $ V( I, I ), LDV, T( 1, I ), LDT,
+ IB = MIN( MB, K-I+1 )
+ CALL SLARFB( 'L', 'N', 'F', 'R', M-I+1, N, IB,
+ $ V( I, I ), LDV, T( 1, I ), LDT,
$ C( I, 1 ), LDC, WORK, LDWORK )
END DO
*
*
KF = ((K-1)/MB)*MB+1
DO I = KF, 1, -MB
- IB = MIN( MB, K-I+1 )
- CALL SLARFB( 'R', 'T', 'F', 'R', M, N-I+1, IB,
- $ V( I, I ), LDV, T( 1, I ), LDT,
+ IB = MIN( MB, K-I+1 )
+ CALL SLARFB( 'R', 'T', 'F', 'R', M, N-I+1, IB,
+ $ V( I, I ), LDV, T( 1, I ), LDT,
$ C( 1, I ), LDC, WORK, LDWORK )
END DO
*
-*
+*
* Definition:
* ===========
*
-* SUBROUTINE SGEMQR( SIDE, TRANS, M, N, K, A, LDA, WORK1,
+* SUBROUTINE SGEMQR( SIDE, TRANS, M, N, K, A, LDA, WORK1,
* $ LWORK1, C, LDC, WORK2, LWORK2, INFO )
*
*
* =============
*>
*> \verbatim
-*>
+*>
*> SGEMQR overwrites the general real M-by-N matrix C with
*>
-*>
+*>
*> SIDE = 'L' SIDE = 'R'
*> TRANS = 'N': Q * C C * Q
*> TRANS = 'T': Q**T * C C * Q**T
-*> where Q is a real orthogonal matrix defined as the product
-*> of blocked elementary reflectors computed by tall skinny
+*> where Q is a real orthogonal matrix defined as the product
+*> of blocked elementary reflectors computed by tall skinny
*> QR factorization (DGEQR)
*> \endverbatim
*
*> The number of elementary reflectors whose product defines
*> the matrix Q.
*> N >= K >= 0;
-*>
+*>
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is REAL array, dimension (LDA,K)
-*> The i-th column must contain the vector which defines the
-*> blockedelementary reflector H(i), for i = 1,2,...,k, as
-*> returned by DGETSQR in the first k columns of
+*> The i-th column must contain the vector which defines the
+*> blockedelementary reflector H(i), for i = 1,2,...,k, as
+*> returned by DGETSQR in the first k columns of
*> its array argument A.
*> \endverbatim
*>
*> \param[out] WORK2
*> \verbatim
*> (workspace) REAL array, dimension (MAX(1,LWORK2))
-*>
+*>
*> \endverbatim
*> \param[in] LWORK2
*> \verbatim
*> LWORK2 is INTEGER
-*> The dimension of the array WORK2.
+*> The dimension of the array WORK2.
*> If LWORK2 = -1, then a workspace query is assumed; the routine
*> only calculates the optimal size of the WORK2 array, returns
-*> this value as the third entry of the WORK2 array (WORK2(1)),
+*> this value as the third entry of the WORK2 array (WORK2(1)),
*> and no error message related to LWORK2 is issued by XERBLA.
*>
*> \endverbatim
*> Depending on the matrix dimensions M and N, and row and column
*> block sizes MB and NB returned by ILAENV, GEQR will use either
*> LATSQR (if the matrix is tall-and-skinny) or GEQRT to compute
-*> the QR decomposition.
+*> the QR decomposition.
*> The output of LATSQR or GEQRT representing Q is stored in A and in
-*> array WORK1(6:LWORK1) for later use.
-*> WORK1(2:5) contains the matrix dimensions M,N and block sizes MB,NB
-*> which are needed to interpret A and WORK1(6:LWORK1) for later use.
-*> WORK1(1)=1 indicates that the code needed to take WORK1(2:5) and
-*> decide whether LATSQR or GEQRT was used is the same as used below in
+*> array WORK1(6:LWORK1) for later use.
+*> WORK1(2:5) contains the matrix dimensions M,N and block sizes MB,NB
+*> which are needed to interpret A and WORK1(6:LWORK1) for later use.
+*> WORK1(1)=1 indicates that the code needed to take WORK1(2:5) and
+*> decide whether LATSQR or GEQRT was used is the same as used below in
*> GEQR. For a detailed description of A and WORK1(6:LWORK1), see
*> Further Details in LATSQR or GEQRT.
*> \endverbatim
*>
* =====================================================================
- SUBROUTINE SGEMQR( SIDE, TRANS, M, N, K, A, LDA, WORK1, LWORK1,
+ SUBROUTINE SGEMQR( SIDE, TRANS, M, N, K, A, LDA, WORK1, LWORK1,
$ C, LDC, WORK2, LWORK2, INFO )
*
* -- LAPACK computational routine (version 3.5.0) --
LOGICAL LSAME
EXTERNAL LSAME
* .. External Subroutines ..
- EXTERNAL SGEMQRT, STPMQRT, XERBLA
+ EXTERNAL SGEMQRT, STPMQRT, XERBLA
* .. Intrinsic Functions ..
INTRINSIC INT, MAX, MIN, MOD
* ..
ELSE IF(RIGHT) THEN
LW = MB * NB
MN = N
- END IF
+ END IF
*
IF ((MB.GT.K).AND.(MN.GT.K)) THEN
IF(MOD(MN-K, MB-K).EQ.0) THEN
END IF
*
* Determine the block size if it is tall skinny or short and wide
-*
+*
IF( INFO.EQ.0) THEN
- WORK2(1) = LW
+ WORK2(1) = LW
END IF
*
IF( INFO.NE.0 ) THEN
*
IF((LEFT.AND.M.LE.K).OR.(RIGHT.AND.N.LE.K).OR.(MB.LE.K).OR.
$ (MB.GE.MAX(M,N,K))) THEN
- CALL SGEMQRT( SIDE, TRANS, M, N, K, NB, A, LDA,
- $ WORK1(6), NB, C, LDC, WORK2, INFO)
+ CALL SGEMQRT( SIDE, TRANS, M, N, K, NB, A, LDA,
+ $ WORK1(6), NB, C, LDC, WORK2, INFO)
ELSE
CALL SLAMTSQR( SIDE, TRANS, M, N, K, MB, NB, A, LDA, WORK1(6),
$ NB, C, LDC, WORK2, LWORK2, INFO )
- END IF
+ END IF
*
WORK2(1) = LW
-*
+*
RETURN
*
* End of SGEMQR
*
- END
\ No newline at end of file
+ END
-*
+*
* Definition:
* ===========
*
* SUBROUTINE SGEQR( M, N, A, LDA, WORK1, LWORK1, WORK2, LWORK2,
* INFO)
-*
+*
* .. Scalar Arguments ..
* INTEGER INFO, LDA, M, N, LWORK1, LWORK2
* ..
* .. Array Arguments ..
* REAL A( LDA, * ), WORK1( * ), WORK2( * )
* ..
-*
+*
*
*> \par Purpose:
* =============
*>
*> \verbatim
-*>
-*> SGEQR computes a QR factorization of an M-by-N matrix A,
-*> using SLATSQR when A is tall and skinny
-*> (M sufficiently greater than N), and otherwise SGEQRT:
+*>
+*> SGEQR computes a QR factorization of an M-by-N matrix A,
+*> using SLATSQR when A is tall and skinny
+*> (M sufficiently greater than N), and otherwise SGEQRT:
*> A = Q * R .
*> \endverbatim
*
*> A is REAL array, dimension (LDA,N)
*> On entry, the M-by-N matrix A.
*> On exit, the elements on and above the diagonal of the array
-*> contain the min(M,N)-by-N upper trapezoidal matrix R
+*> contain the min(M,N)-by-N upper trapezoidal matrix R
*> (R is upper triangular if M >= N);
*> the elements below the diagonal represent Q (see Further Details).
*> \endverbatim
*> \verbatim
*> WORK1 is REAL array, dimension (MAX(1,LWORK1))
*> WORK1 contains part of the data structure used to store Q.
-*> WORK1(1): algorithm type = 1, to indicate output from
+*> WORK1(1): algorithm type = 1, to indicate output from
*> DLATSQR or DGEQRT
*> WORK1(2): optimum size of WORK1
*> WORK1(3): minimum size of WORK1
*> WORK1(4): row block size
*> WORK1(5): column block size
-*> WORK1(6:LWORK1): data structure needed for Q, computed by
+*> WORK1(6:LWORK1): data structure needed for Q, computed by
*> SLATSQR or SGEQRT
*> \endverbatim
*>
*> \verbatim
*> LWORK1 is INTEGER
*> The dimension of the array WORK1.
-*> If LWORK1 = -1, then a query is assumed. In this case the
+*> If LWORK1 = -1, then a query is assumed. In this case the
*> routine calculates the optimal size of WORK1 and
-*> returns this value in WORK1(2), and calculates the minimum
-*> size of WORK1 and returns this value in WORK1(3).
-*> No error message related to LWORK1 is issued by XERBLA when
+*> returns this value in WORK1(2), and calculates the minimum
+*> size of WORK1 and returns this value in WORK1(3).
+*> No error message related to LWORK1 is issued by XERBLA when
*> LWORK1 = -1.
*> \endverbatim
*>
*> \param[out] WORK2
*> \verbatim
-*> (workspace) REAL array, dimension (MAX(1,LWORK2))
+*> (workspace) REAL array, dimension (MAX(1,LWORK2))
*> \endverbatim
*>
*> \param[in] LWORK2
*> \verbatim
*> LWORK2 is INTEGER
*> The dimension of the array WORK2.
-*> If LWORK2 = -1, then a query is assumed. In this case the
-*> routine calculates the optimal size of WORK2 and
+*> If LWORK2 = -1, then a query is assumed. In this case the
+*> routine calculates the optimal size of WORK2 and
*> returns this value in WORK2(1), and calculates the minimum
*> size of WORK2 and returns this value in WORK2(2).
*> No error message related to LWORK2 is issued by XERBLA when
*> Depending on the matrix dimensions M and N, and row and column
*> block sizes MB and NB returned by ILAENV, GEQR will use either
*> LATSQR (if the matrix is tall-and-skinny) or GEQRT to compute
-*> the QR decomposition.
+*> the QR decomposition.
*> The output of LATSQR or GEQRT representing Q is stored in A and in
-*> array WORK1(6:LWORK1) for later use.
-*> WORK1(2:5) contains the matrix dimensions M,N and block sizes MB,NB
-*> which are needed to interpret A and WORK1(6:LWORK1) for later use.
-*> WORK1(1)=1 indicates that the code needed to take WORK1(2:5) and
-*> decide whether LATSQR or GEQRT was used is the same as used below in
-*> GEQR. For a detailed description of A and WORK1(6:LWORK1), see
+*> array WORK1(6:LWORK1) for later use.
+*> WORK1(2:5) contains the matrix dimensions M,N and block sizes MB,NB
+*> which are needed to interpret A and WORK1(6:LWORK1) for later use.
+*> WORK1(1)=1 indicates that the code needed to take WORK1(2:5) and
+*> decide whether LATSQR or GEQRT was used is the same as used below in
+*> GEQR. For a detailed description of A and WORK1(6:LWORK1), see
*> Further Details in LATSQR or GEQRT.
*> \endverbatim
*>
* =====================================================================
- SUBROUTINE SGEQR( M, N, A, LDA, WORK1, LWORK1, WORK2, LWORK2,
+ SUBROUTINE SGEQR( M, N, A, LDA, WORK1, LWORK1, WORK2, LWORK2,
$ INFO)
*
* -- LAPACK computational routine (version 3.5.0) --
*
LQUERY = ( LWORK1.EQ.-1 .OR. LWORK2.EQ.-1 )
*
-* Determine the block size
-*
+* Determine the block size
+*
IF ( MIN(M,N).GT.0 ) THEN
MB = ILAENV( 1, 'SGEQR ', ' ', M, N, 1, -1)
NB = ILAENV( 1, 'SGEQR ', ' ', M, N, 2, -1)
END IF
*
* Determine if the workspace size satisfies minimum size
-*
+*
LMINWS = .FALSE.
- IF((LWORK1.LT.MAX(1, NB*N*NBLCKS+5)
- $ .OR.(LWORK2.LT.NB*N)).AND.(LWORK2.GE.N).AND.(LWORK1.GT.N+5)
+ IF((LWORK1.LT.MAX(1, NB*N*NBLCKS+5)
+ $ .OR.(LWORK2.LT.NB*N)).AND.(LWORK2.GE.N).AND.(LWORK1.GT.N+5)
$ .AND.(.NOT.LQUERY)) THEN
IF (LWORK1.LT.MAX(1, NB * N * NBLCKS+5)) THEN
LMINWS = .TRUE.
NB = 1
- END IF
+ END IF
IF (LWORK1.LT.MAX(1, N * NBLCKS+5)) THEN
LMINWS = .TRUE.
- MB = M
+ MB = M
END IF
IF (LWORK2.LT.NB*N) THEN
LMINWS = .TRUE.
INFO = -2
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -4
- ELSE IF( LWORK1.LT.MAX( 1, NB * N * NBLCKS + 5 )
+ ELSE IF( LWORK1.LT.MAX( 1, NB * N * NBLCKS + 5 )
$ .AND.(.NOT.LQUERY).AND.(.NOT.LMINWS)) THEN
INFO = -6
- ELSE IF( (LWORK2.LT.MAX(1,N*NB)).AND.(.NOT.LQUERY)
+ ELSE IF( (LWORK2.LT.MAX(1,N*NB)).AND.(.NOT.LQUERY)
$ .AND.(.NOT.LMINWS)) THEN
- INFO = -8
- END IF
+ INFO = -8
+ END IF
IF( INFO.EQ.0) THEN
WORK1(1) = 1
*
IF((M.LE.N).OR.(MB.LE.N).OR.(MB.GE.M)) THEN
CALL SGEQRT( M, N, NB, A, LDA, WORK1(6), NB, WORK2, INFO)
- ELSE
- CALL SLATSQR( M, N, MB, NB, A, LDA, WORK1(6), NB, WORK2,
+ ELSE
+ CALL SLATSQR( M, N, MB, NB, A, LDA, WORK1(6), NB, WORK2,
$ LWORK2, INFO)
END IF
RETURN
-*
+*
* End of SGEQR
*
- END
\ No newline at end of file
+ END
* SUBROUTINE SGETSLS( TRANS, M, N, NRHS, A, LDA, B, LDB
* $ , WORK, LWORK, INFO )
-*
+*
* .. Scalar Arguments ..
* CHARACTER TRANS
* INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS
* .. Array Arguments ..
* REAL A( LDA, * ), B( LDB, * ), WORK( * )
* ..
-*
+*
*
*> \par Purpose:
* =============
*> \verbatim
*>
*> SGETSLS solves overdetermined or underdetermined real linear systems
-*> involving an M-by-N matrix A, using a tall skinny QR or short wide LQ
+*> involving an M-by-N matrix A, using a tall skinny QR or short wide LQ
*> factorization of A. It is assumed that A has full rank.
*>
-*>
+*>
*>
*> The following options are provided:
*>
*> \verbatim
*> LWORK is INTEGER
*> The dimension of the array WORK.
-*> IF LWORK=-1, workspace query is assumed, and
+*> IF LWORK=-1, workspace query is assumed, and
*> WORK(1) returns the optimal LWORK,
*> and WORK(2) returns the minimum LWORK.
*> \endverbatim
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
*> \date November 2011
*
EXTERNAL LSAME, ILAENV, SLABAD, SLAMCH, SLANGE
* ..
* .. External Subroutines ..
- EXTERNAL SGEQR, SGEMQR, SLASCL, SLASET,
+ EXTERNAL SGEQR, SGEMQR, SLASCL, SLASET,
$ STRTRS, XERBLA, SGELQ, SGEMLQ
* ..
* .. Intrinsic Functions ..
TRAN = LSAME( TRANS, 'T' )
*
LQUERY = ( LWORK.EQ.-1 )
- IF( .NOT.( LSAME( TRANS, 'N' ) .OR.
+ IF( .NOT.( LSAME( TRANS, 'N' ) .OR.
$ LSAME( TRANS, 'T' ) ) ) THEN
INFO = -1
ELSE IF( M.LT.0 ) THEN
IF( INFO.EQ.0) THEN
*
* Determine the block size and minimum LWORK
-*
+*
IF ( M.GE.N ) THEN
- CALL SGEQR( M, N, A, LDA, WORK(1), -1, WORK(6), -1,
+ CALL SGEQR( M, N, A, LDA, WORK(1), -1, WORK(6), -1,
$ INFO2)
MB = INT(WORK(4))
NB = INT(WORK(5))
$ INT(WORK(2)), B, LDB, WORK(6), -1 , INFO2 )
WSIZEO = INT(WORK(2))+MAX(LW,INT(WORK(6)))
WSIZEM = INT(WORK(3))+MAX(LW,INT(WORK(6)))
- ELSE
- CALL SGELQ( M, N, A, LDA, WORK(1), -1, WORK(6), -1,
+ ELSE
+ CALL SGELQ( M, N, A, LDA, WORK(1), -1, WORK(6), -1,
$ INFO2)
MB = INT(WORK(4))
NB = INT(WORK(5))
* Quick return if possible
*
IF( MIN( M, N, NRHS ).EQ.0 ) THEN
- CALL SLASET( 'FULL', MAX( M, N ), NRHS, ZERO, ZERO,
+ CALL SLASET( 'FULL', MAX( M, N ), NRHS, ZERO, ZERO,
$ B, LDB )
RETURN
END IF
*
* B(1:M,1:NRHS) := Q**T * B(1:M,1:NRHS)
*
- CALL SGEMQR( 'L' , 'T', M, NRHS, N, A, LDA,
+ CALL SGEMQR( 'L' , 'T', M, NRHS, N, A, LDA,
$ WORK(LW2+1), LW1, B, LDB, WORK(1), LW2, INFO )
*
* B(1:N,1:NRHS) := inv(R) * B(1:N,1:NRHS)
*
CALL SGEMQR( 'L', 'N', M, NRHS, N, A, LDA,
$ WORK( LW2+1), LW1, B, LDB, WORK( 1 ), LW2,
- $ INFO )
+ $ INFO )
*
SCLLEN = M
*
*
* End of SGETSLS
*
- END
\ No newline at end of file
+ END
-*
+*
* Definition:
* ===========
*
-* SUBROUTINE SLAMSWLQ( SIDE, TRANS, M, N, K, MB, NB, A, LDA, T,
+* SUBROUTINE SLAMSWLQ( SIDE, TRANS, M, N, K, MB, NB, A, LDA, T,
* $ LDT, C, LDC, WORK, LWORK, INFO )
*
*
* =============
*>
*> \verbatim
-*>
+*>
*> DLAMQRTS overwrites the general real M-by-N matrix C with
*>
-*>
+*>
*> SIDE = 'L' SIDE = 'R'
*> TRANS = 'N': Q * C C * Q
*> TRANS = 'T': Q**T * C C * Q**T
*> where Q is a real orthogonal matrix defined as the product of blocked
-*> elementary reflectors computed by short wide LQ
+*> elementary reflectors computed by short wide LQ
*> factorization (DLASWLQ)
*> \endverbatim
*
*> The number of elementary reflectors whose product defines
*> the matrix Q.
*> M >= K >= 0;
-*>
+*>
*> \endverbatim
*> \param[in] MB
*> \verbatim
*> MB is INTEGER
-*> The row block size to be used in the blocked QR.
-*> M >= MB >= 1
+*> The row block size to be used in the blocked QR.
+*> M >= MB >= 1
*> \endverbatim
*>
*> \param[in] NB
*> \verbatim
*> NB is INTEGER
-*> The column block size to be used in the blocked QR.
+*> The column block size to be used in the blocked QR.
*> NB > M.
*> \endverbatim
*>
*> \param[in] NB
*> \verbatim
*> NB is INTEGER
-*> The block size to be used in the blocked QR.
+*> The block size to be used in the blocked QR.
*> MB > M.
-*>
+*>
*> \endverbatim
*>
*> \param[in,out] A
*>
*> \param[in] T
*> \verbatim
-*> T is REAL array, dimension
+*> T is REAL array, dimension
*> ( M * Number of blocks(CEIL(N-K/NB-K)),
*> The blocked upper triangular block reflectors stored in compact form
*> as a sequence of upper triangular blocks. See below
*> \param[out] WORK
*> \verbatim
*> (workspace) REAL array, dimension (MAX(1,LWORK))
-*>
+*>
*> \endverbatim
*> \param[in] LWORK
*> \verbatim
*> block reflectors, stored in array T(1:LDT,(i-1)*M+1:i*M).
*> The last Q(k) may use fewer rows.
*> For more information see Further Details in TPQRT.
-*>
+*>
*> For more details of the overall algorithm, see the description of
*> Sequential TSQR in Section 2.2 of [1].
*>
*> \endverbatim
*>
* =====================================================================
- SUBROUTINE SLAMSWLQ( SIDE, TRANS, M, N, K, MB, NB, A, LDA, T,
+ SUBROUTINE SLAMSWLQ( SIDE, TRANS, M, N, K, MB, NB, A, LDA, T,
$ LDT, C, LDC, WORK, LWORK, INFO )
*
* -- LAPACK computational routine (version 3.5.0) --
END IF
*
IF((NB.LE.K).OR.(NB.GE.MAX(M,N,K))) THEN
- CALL DGEMLQT( SIDE, TRANS, M, N, K, MB, A, LDA,
- $ T, LDT, C, LDC, WORK, INFO)
+ CALL DGEMLQT( SIDE, TRANS, M, N, K, MB, A, LDA,
+ $ T, LDT, C, LDC, WORK, INFO)
RETURN
END IF
*
IF(II.LE.N) THEN
*
* Multiply Q to the last block of C
-*
+*
CALL STPMLQT('R','T',M , KK, K, 0,MB, A(1,II), LDA,
$ T(1,CTR*K+1),LDT, C(1,1), LDC,
$ C(1,II), LDC, WORK, INFO )
*
* End of SLAMSWLQ
*
- END
\ No newline at end of file
+ END
-*
+*
* Definition:
* ===========
*
-* SUBROUTINE SLAMTSQR( SIDE, TRANS, M, N, K, MB, NB, A, LDA, T,
+* SUBROUTINE SLAMTSQR( SIDE, TRANS, M, N, K, MB, NB, A, LDA, T,
* $ LDT, C, LDC, WORK, LWORK, INFO )
*
*
* =============
*>
*> \verbatim
-*>
+*>
*> SLAMTSQR overwrites the general real M-by-N matrix C with
*>
-*>
+*>
*> SIDE = 'L' SIDE = 'R'
*> TRANS = 'N': Q * C C * Q
*> TRANS = 'T': Q**T * C C * Q**T
-*> where Q is a real orthogonal matrix defined as the product
-*> of blocked elementary reflectors computed by tall skinny
+*> where Q is a real orthogonal matrix defined as the product
+*> of blocked elementary reflectors computed by tall skinny
*> QR factorization (DLATSQR)
*> \endverbatim
*
*> The number of elementary reflectors whose product defines
*> the matrix Q.
*> N >= K >= 0;
-*>
+*>
*> \endverbatim
*>
*> \param[in] MB
*> \verbatim
*> MB is INTEGER
-*> The block size to be used in the blocked QR.
+*> The block size to be used in the blocked QR.
*> MB > N. (must be the same as DLATSQR)
*> \endverbatim
*>
*> \param[in] NB
*> \verbatim
*> NB is INTEGER
-*> The column block size to be used in the blocked QR.
+*> The column block size to be used in the blocked QR.
*> N >= NB >= 1.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is REAL array, dimension (LDA,K)
-*> The i-th column must contain the vector which defines the
-*> blockedelementary reflector H(i), for i = 1,2,...,k, as
-*> returned by DLATSQR in the first k columns of
+*> The i-th column must contain the vector which defines the
+*> blockedelementary reflector H(i), for i = 1,2,...,k, as
+*> returned by DLATSQR in the first k columns of
*> its array argument A.
*> \endverbatim
*>
*>
*> \param[in] T
*> \verbatim
-*> T is REAL array, dimension
+*> T is REAL array, dimension
*> ( N * Number of blocks(CEIL(M-K/MB-K)),
*> The blocked upper triangular block reflectors stored in compact form
*> as a sequence of upper triangular blocks. See below
*> \param[out] WORK
*> \verbatim
*> (workspace) REAL array, dimension (MAX(1,LWORK))
-*>
+*>
*> \endverbatim
*> \param[in] LWORK
*> \verbatim
*> LWORK is INTEGER
*> The dimension of the array WORK.
-*>
+*>
*> If SIDE = 'L', LWORK >= max(1,N)*NB;
*> if SIDE = 'R', LWORK >= max(1,MB)*NB.
*> If LWORK = -1, then a workspace query is assumed; the routine
*> block reflectors, stored in array T(1:LDT,(i-1)*N+1:i*N).
*> The last Q(k) may use fewer rows.
*> For more information see Further Details in TPQRT.
-*>
+*>
*> For more details of the overall algorithm, see the description of
*> Sequential TSQR in Section 2.2 of [1].
*>
*> \endverbatim
*>
* =====================================================================
- SUBROUTINE SLAMTSQR( SIDE, TRANS, M, N, K, MB, NB, A, LDA, T,
+ SUBROUTINE SLAMTSQR( SIDE, TRANS, M, N, K, MB, NB, A, LDA, T,
$ LDT, C, LDC, WORK, LWORK, INFO )
*
* -- LAPACK computational routine (version 3.5.0) --
* ..
* .. Local Scalars ..
LOGICAL LEFT, RIGHT, TRAN, NOTRAN, LQUERY
- INTEGER I, II, KK, LW, CTR
+ INTEGER I, II, KK, LW, CTR
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* .. External Subroutines ..
- EXTERNAL SGEMQRT, STPMQRT, XERBLA
+ EXTERNAL SGEMQRT, STPMQRT, XERBLA
* ..
* .. Executable Statements ..
*
IF( INFO.EQ.0) THEN
*
* Determine the block size if it is tall skinny or short and wide
-*
+*
IF( INFO.EQ.0) THEN
WORK(1) = LW
END IF
END IF
*
IF((MB.LE.K).OR.(MB.GE.MAX(M,N,K))) THEN
- CALL SGEMQRT( SIDE, TRANS, M, N, K, NB, A, LDA,
- $ T, LDT, C, LDC, WORK, INFO)
+ CALL SGEMQRT( SIDE, TRANS, M, N, K, NB, A, LDA,
+ $ T, LDT, C, LDC, WORK, INFO)
RETURN
- END IF
+ END IF
*
IF(LEFT.AND.NOTRAN) THEN
*
CALL STPMQRT('L','N',MB-K , N, K, 0,NB, A(I,1), LDA,
$ T(1, CTR * K + 1), LDT, C(1,1), LDC,
$ C(I,1), LDC, WORK, INFO )
-*
+*
END DO
*
* Multiply Q to the first block of C (1:MB,1:N)
IF(II.LE.M) THEN
*
* Multiply Q to the last block of C
-*
+*
CALL STPMQRT('L','T',KK , N, K, 0,NB, A(II,1), LDA,
$ T(1, CTR * K + 1), LDT, C(1,1), LDC,
$ C(II,1), LDC, WORK, INFO )
*
END IF
*
- WORK(1) = LW
+ WORK(1) = LW
RETURN
*
* End of SLAMTSQR
*
- END
\ No newline at end of file
+ END
-*
+*
* Definition:
* ===========
*
* SUBROUTINE SLASWLQ( M, N, MB, NB, A, LDA, T, LDT, WORK,
* LWORK, INFO)
-*
+*
* .. Scalar Arguments ..
* INTEGER INFO, LDA, M, N, MB, NB, LDT, LWORK
* ..
* .. Array Arguments ..
* REAL A( LDA, * ), T( LDT, * ), WORK( * )
* ..
-*
+*
*
*> \par Purpose:
* =============
*>
*> \verbatim
-*>
-*> SLASWLQ computes a blocked Short-Wide LQ factorization of a
+*>
+*> SLASWLQ computes a blocked Short-Wide LQ factorization of a
*> M-by-N matrix A, where N >= M:
*> A = L * Q
*> \endverbatim
*> \param[in] MB
*> \verbatim
*> MB is INTEGER
-*> The row block size to be used in the blocked QR.
-*> M >= MB >= 1
+*> The row block size to be used in the blocked QR.
+*> M >= MB >= 1
*> \endverbatim
*> \param[in] NB
*> \verbatim
*> NB is INTEGER
-*> The column block size to be used in the blocked QR.
+*> The column block size to be used in the blocked QR.
*> NB > M.
*> \endverbatim
*>
*> \verbatim
*> A is REAL array, dimension (LDA,N)
*> On entry, the M-by-N matrix A.
-*> On exit, the elements on and bleow the diagonal
-*> of the array contain the N-by-N lower triangular matrix L;
-*> the elements above the diagonal represent Q by the rows
+*> On exit, the elements on and bleow the diagonal
+*> of the array contain the N-by-N lower triangular matrix L;
+*> the elements above the diagonal represent Q by the rows
*> of blocked V (see Further Details).
*>
*> \endverbatim
*>
*> \param[out] T
*> \verbatim
-*> T is REAL array,
-*> dimension (LDT, N * Number_of_row_blocks)
+*> T is REAL array,
+*> dimension (LDT, N * Number_of_row_blocks)
*> where Number_of_row_blocks = CEIL((N-M)/(NB-M))
*> The blocked upper triangular block reflectors stored in compact form
-*> as a sequence of upper triangular blocks.
+*> as a sequence of upper triangular blocks.
*> See Further Details below.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> (workspace) REAL array, dimension (MAX(1,LWORK))
-*>
+*>
*> \endverbatim
*> \param[in] LWORK
*> \verbatim
*> block reflectors, stored in array T(1:LDT,(i-1)*M+1:i*M).
*> The last Q(k) may use fewer rows.
*> For more information see Further Details in TPQRT.
-*>
+*>
*> For more details of the overall algorithm, see the description of
*> Sequential TSQR in Section 2.2 of [1].
*>
*> \endverbatim
*>
* =====================================================================
- SUBROUTINE SLASWLQ( M, N, MB, NB, A, LDA, T, LDT, WORK, LWORK,
+ SUBROUTINE SLASWLQ( M, N, MB, NB, A, LDA, T, LDT, WORK, LWORK,
$ INFO)
*
* -- LAPACK computational routine (version 3.5.0) --
ELSE IF( N.LT.0 .OR. N.LT.M ) THEN
INFO = -2
ELSE IF( MB.LT.1 .OR. ( MB.GT.M .AND. M.GT.0 )) THEN
- INFO = -3
+ INFO = -3
ELSE IF( NB.LE.M ) THEN
INFO = -4
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
ELSE IF( LDT.LT.MB ) THEN
INFO = -8
ELSE IF( ( LWORK.LT.M*MB) .AND. (.NOT.LQUERY) ) THEN
- INFO = -10
- END IF
- IF( INFO.EQ.0) THEN
+ INFO = -10
+ END IF
+ IF( INFO.EQ.0) THEN
WORK(1) = MB*M
END IF
*
IF((M.GE.N).OR.(NB.LE.M).OR.(NB.GE.N)) THEN
CALL SGELQT( M, N, MB, A, LDA, T, LDT, WORK, INFO)
RETURN
- END IF
-*
+ END IF
+*
KK = MOD((N-M),(NB-M))
- II=N-KK+1
+ II=N-KK+1
*
* Compute the LQ factorization of the first block A(1:M,1:NB)
*
CTR = 1
*
DO I = NB+1, II-NB+M , (NB-M)
-*
+*
* Compute the QR factorization of the current block A(1:M,I:I+NB-M)
*
CALL STPLQT( M, NB-M, 0, MB, A(1,1), LDA, A( 1, I ),
CALL STPLQT( M, KK, 0, MB, A(1,1), LDA, A( 1, II ),
$ LDA, T(1, CTR * M + 1), LDT,
$ WORK, INFO )
- END IF
+ END IF
*
WORK( 1 ) = M * MB
RETURN
-*
+*
* End of SLASWLQ
*
- END
\ No newline at end of file
+ END
*
* =========== DOCUMENTATION ===========
*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
-*> Download SLASYF_AASEN + dependencies
-*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/slasyf_aasen.f">
-*> [TGZ]</a>
-*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/slasyf_aasen.f">
-*> [ZIP]</a>
-*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/slasyf_aasen.f">
+*> Download SLASYF_AASEN + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/slasyf_aasen.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/slasyf_aasen.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/slasyf_aasen.f">
*> [TXT]</a>
-*> \endhtmlonly
+*> \endhtmlonly
*
* Definition:
* ===========
*
-* SUBROUTINE SLASYF_AASEN( UPLO, J1, M, NB, A, LDA, IPIV,
+* SUBROUTINE SLASYF_AASEN( UPLO, J1, M, NB, A, LDA, IPIV,
* H, LDH, WORK, INFO )
-*
+*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER J1, M, NB, LDA, LDH, INFO
* INTEGER IPIV( * )
* REAL A( LDA, * ), H( LDH, * ), WORK( * )
* ..
-*
+*
*
*> \par Purpose:
* =============
*> last row, or column, of the previous panel. The first row, or column,
*> of A is set to be the first row, or column, of an identity matrix,
*> which is used to factorize the first panel.
-*>
+*>
*> The resulting J-th row of U, or J-th column of L, is stored in the
-*> (J-1)-th row, or column, of A (without the unit diatonals), while
+*> (J-1)-th row, or column, of A (without the unit diatonals), while
*> the diagonal and subdiagonal of A are overwritten by those of T.
*>
*> \endverbatim
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
*> \date November 2016
*
* @generated from dlasyf_aasen.f, fortran d -> s, Sun Oct 2 22:57:56 2016
*
* =====================================================================
- SUBROUTINE SLASYF_AASEN( UPLO, J1, M, NB, A, LDA, IPIV,
+ SUBROUTINE SLASYF_AASEN( UPLO, J1, M, NB, A, LDA, IPIV,
$ H, LDH, WORK, INFO )
*
* -- LAPACK computational routine (version 3.4.0) --
*
* .. Local Scalars ..
INTEGER J, K, K1, I1, I2
- REAL PIV, ALPHA
+ REAL PIV, ALPHA
* ..
* .. External Functions ..
LOGICAL LSAME
*
A( K, J ) = WORK( 1 )
*
- IF( J.LT.M ) THEN
+ IF( J.LT.M ) THEN
*
* Compute WORK(2:N) = T(J, J) L(J, (J+1):N)
* where A(J, J) stores T(J, J) and A(J-1, (J+1):N) stores U(J, (J+1):N)
*
IF( (J1+J-1).GT.1 ) THEN
- ALPHA = -A( K, J )
- CALL SAXPY( M-J, ALPHA, A( K-1, J+1 ), LDA,
+ ALPHA = -A( K, J )
+ CALL SAXPY( M-J, ALPHA, A( K-1, J+1 ), LDA,
$ WORK( 2 ), 1 )
ENDIF
*
*
I1 = I1+J-1
I2 = I2+J-1
- CALL SSWAP( I2-I1-1, A( J1+I1-1, I1+1 ), LDA,
+ CALL SSWAP( I2-I1-1, A( J1+I1-1, I1+1 ), LDA,
$ A( J1+I1, I2 ), 1 )
*
* Swap A(I1, I2+1:N) with A(I2, I2+1:N)
*
- CALL SSWAP( M-I2, A( J1+I1-1, I2+1 ), LDA,
+ CALL SSWAP( M-I2, A( J1+I1-1, I2+1 ), LDA,
$ A( J1+I2-1, I2+1 ), LDA )
*
* Swap A(I1, I1) with A(I2,I2)
* Swap L(1:I1-1, I1) with L(1:I1-1, I2),
* skipping the first column
*
- CALL SSWAP( I1-K1+1, A( 1, I1 ), 1,
+ CALL SSWAP( I1-K1+1, A( 1, I1 ), 1,
$ A( 1, I2 ), 1 )
END IF
- ELSE
+ ELSE
IPIV( J+1 ) = J+1
ENDIF
*
* Set A(J, J+1) = T(J, J+1)
*
A( K, J+1 ) = WORK( 2 )
- IF( (A( K, J ).EQ.ZERO ) .AND.
+ IF( (A( K, J ).EQ.ZERO ) .AND.
$ ( (J.EQ.M) .OR. (A( K, J+1 ).EQ.ZERO))) THEN
IF(INFO .EQ. 0) THEN
INFO = J
*
IF( J.LT.NB ) THEN
*
-* Copy A(J+1:N, J+1) into H(J:N, J),
+* Copy A(J+1:N, J+1) into H(J:N, J),
*
- CALL SCOPY( M-J, A( K+1, J+1 ), LDA,
+ CALL SCOPY( M-J, A( K+1, J+1 ), LDA,
$ H( J+1, J+1 ), 1 )
END IF
*
CALL SCOPY( M-J-1, WORK( 3 ), 1, A( K, J+2 ), LDA )
CALL SSCAL( M-J-1, ALPHA, A( K, J+2 ), LDA )
ELSE
- CALL SLASET( 'Full', 1, M-J-1, ZERO, ZERO,
+ CALL SLASET( 'Full', 1, M-J-1, ZERO, ZERO,
$ A( K, J+2 ), LDA)
END IF
ELSE
*
A( J, K ) = WORK( 1 )
*
- IF( J.LT.M ) THEN
+ IF( J.LT.M ) THEN
*
* Compute WORK(2:N) = T(J, J) L((J+1):N, J)
* where A(J, J) = T(J, J) and A((J+1):N, J-1) = L((J+1):N, J)
*
IF( (J1+J-1).GT.1 ) THEN
- ALPHA = -A( J, K )
- CALL SAXPY( M-J, ALPHA, A( J+1, K-1 ), 1,
+ ALPHA = -A( J, K )
+ CALL SAXPY( M-J, ALPHA, A( J+1, K-1 ), 1,
$ WORK( 2 ), 1 )
ENDIF
*
*
I1 = I1+J-1
I2 = I2+J-1
- CALL SSWAP( I2-I1-1, A( I1+1, J1+I1-1 ), 1,
+ CALL SSWAP( I2-I1-1, A( I1+1, J1+I1-1 ), 1,
$ A( I2, J1+I1 ), LDA )
*
* Swap A(I2+1:N, I1) with A(I2+1:N, I2)
*
- CALL SSWAP( M-I2, A( I2+1, J1+I1-1 ), 1,
+ CALL SSWAP( M-I2, A( I2+1, J1+I1-1 ), 1,
$ A( I2+1, J1+I2-1 ), 1 )
*
* Swap A(I1, I1) with A(I2, I2)
* Swap L(1:I1-1, I1) with L(1:I1-1, I2),
* skipping the first column
*
- CALL SSWAP( I1-K1+1, A( I1, 1 ), LDA,
+ CALL SSWAP( I1-K1+1, A( I1, 1 ), LDA,
$ A( I2, 1 ), LDA )
END IF
- ELSE
+ ELSE
IPIV( J+1 ) = J+1
ENDIF
*
* Set A(J+1, J) = T(J+1, J)
*
A( J+1, K ) = WORK( 2 )
- IF( (A( J, K ).EQ.ZERO) .AND.
+ IF( (A( J, K ).EQ.ZERO) .AND.
$ ( (J.EQ.M) .OR. (A( J+1, K ).EQ.ZERO)) ) THEN
- IF (INFO .EQ. 0)
+ IF (INFO .EQ. 0)
$ INFO = J
END IF
*
IF( J.LT.NB ) THEN
*
-* Copy A(J+1:N, J+1) into H(J+1:N, J),
+* Copy A(J+1:N, J+1) into H(J+1:N, J),
*
- CALL SCOPY( M-J, A( J+1, K+1 ), 1,
+ CALL SCOPY( M-J, A( J+1, K+1 ), 1,
$ H( J+1, J+1 ), 1 )
END IF
*
CALL SCOPY( M-J-1, WORK( 3 ), 1, A( J+2, K ), 1 )
CALL SSCAL( M-J-1, ALPHA, A( J+2, K ), 1 )
ELSE
- CALL SLASET( 'Full', M-J-1, 1, ZERO, ZERO,
+ CALL SLASET( 'Full', M-J-1, 1, ZERO, ZERO,
$ A( J+2, K ), LDA )
END IF
ELSE
-*
+*
* Definition:
* ===========
*
-* SUBROUTINE SLATSQR( M, N, MB, NB, A, LDA, T, LDT, WORK,
+* SUBROUTINE SLATSQR( M, N, MB, NB, A, LDA, T, LDT, WORK,
* LWORK, INFO)
-*
+*
* .. Scalar Arguments ..
* INTEGER INFO, LDA, M, N, MB, NB, LDT, LWORK
* ..
* .. Array Arguments ..
* REAL A( LDA, * ), T( LDT, * ), WORK( * )
* ..
-*
+*
*
*> \par Purpose:
* =============
*>
*> \verbatim
-*>
-*> SLATSQR computes a blocked Tall-Skinny QR factorization of
+*>
+*> SLATSQR computes a blocked Tall-Skinny QR factorization of
*> an M-by-N matrix A, where M >= N:
-*> A = Q * R .
+*> A = Q * R .
*> \endverbatim
*
* Arguments:
*> \param[in] MB
*> \verbatim
*> MB is INTEGER
-*> The row block size to be used in the blocked QR.
+*> The row block size to be used in the blocked QR.
*> MB > N.
*> \endverbatim
*>
*> \param[in] NB
*> \verbatim
*> NB is INTEGER
-*> The column block size to be used in the blocked QR.
+*> The column block size to be used in the blocked QR.
*> N >= NB >= 1.
*> \endverbatim
*>
*> \verbatim
*> A is REAL array, dimension (LDA,N)
*> On entry, the M-by-N matrix A.
-*> On exit, the elements on and above the diagonal
-*> of the array contain the N-by-N upper triangular matrix R;
-*> the elements below the diagonal represent Q by the columns
+*> On exit, the elements on and above the diagonal
+*> of the array contain the N-by-N upper triangular matrix R;
+*> the elements below the diagonal represent Q by the columns
*> of blocked V (see Further Details).
*> \endverbatim
*>
*>
*> \param[out] T
*> \verbatim
-*> T is REAL array,
-*> dimension (LDT, N * Number_of_row_blocks)
+*> T is REAL array,
+*> dimension (LDT, N * Number_of_row_blocks)
*> where Number_of_row_blocks = CEIL((M-N)/(MB-N))
*> The blocked upper triangular block reflectors stored in compact form
-*> as a sequence of upper triangular blocks.
+*> as a sequence of upper triangular blocks.
*> See Further Details below.
*> \endverbatim
*>
*>
*> \param[out] WORK
*> \verbatim
-*> (workspace) REAL array, dimension (MAX(1,LWORK))
+*> (workspace) REAL array, dimension (MAX(1,LWORK))
*> \endverbatim
*>
*> \param[in] LWORK
*> block reflectors, stored in array T(1:LDT,(i-1)*N+1:i*N).
*> The last Q(k) may use fewer rows.
*> For more information see Further Details in TPQRT.
-*>
+*>
*> For more details of the overall algorithm, see the description of
*> Sequential TSQR in Section 2.2 of [1].
*>
*> \endverbatim
*>
* =====================================================================
- SUBROUTINE SLATSQR( M, N, MB, NB, A, LDA, T, LDT, WORK,
+ SUBROUTINE SLATSQR( M, N, MB, NB, A, LDA, T, LDT, WORK,
$ LWORK, INFO)
*
* -- LAPACK computational routine (version 3.5.0) --
ELSE IF( N.LT.0 .OR. M.LT.N ) THEN
INFO = -2
ELSE IF( MB.LE.N ) THEN
- INFO = -3
+ INFO = -3
ELSE IF( NB.LT.1 .OR. ( NB.GT.N .AND. N.GT.0 )) THEN
INFO = -4
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
ELSE IF( LDT.LT.NB ) THEN
INFO = -8
ELSE IF( LWORK.LT.(N*NB) .AND. (.NOT.LQUERY) ) THEN
- INFO = -10
- END IF
+ INFO = -10
+ END IF
IF( INFO.EQ.0) THEN
WORK(1) = NB*N
END IF
IF ((MB.LE.N).OR.(MB.GE.M)) THEN
CALL SGEQRT( M, N, NB, A, LDA, T, LDT, WORK, INFO)
RETURN
- END IF
+ END IF
KK = MOD((M-N),(MB-N))
- II=M-KK+1
+ II=M-KK+1
*
* Compute the QR factorization of the first block A(1:MB,1:N)
*
*
CTR = 1
DO I = MB+1, II-MB+N , (MB-N)
-*
+*
* Compute the QR factorization of the current block A(I:I+MB-N,1:N)
*
CALL STPQRT( MB-N, N, 0, NB, A(1,1), LDA, A( I, 1 ), LDA,
CALL STPQRT( KK, N, 0, NB, A(1,1), LDA, A( II, 1 ), LDA,
$ T(1, CTR * N + 1), LDT,
$ WORK, INFO )
- END IF
+ END IF
*
work( 1 ) = N*NB
RETURN
-*
+*
* End of SLATSQR
*
- END
\ No newline at end of file
+ END
*> indicating the nonzero elements in Z. The i-th eigenvector
*> is nonzero only in elements ISUPPZ( 2*i-1 ) through
*> ISUPPZ( 2*i ). This is an output of SSTEMR (tridiagonal
-*> matrix). The support of the eigenvectors of A is typically
+*> matrix). The support of the eigenvectors of A is typically
*> 1:N because of the orthogonal transformations applied by SORMTR.
*> Implemented only for RANGE = 'A' or 'I' and IU - IL = N - 1
*> \endverbatim
*
* =========== DOCUMENTATION ===========
*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
-*> Download SSYSV_AASEN + dependencies
-*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ssysv_aasen.f">
-*> [TGZ]</a>
-*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ssysv_aasen.f">
-*> [ZIP]</a>
-*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ssysv_aasen.f">
+*> Download SSYSV_AASEN + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ssysv_aasen.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ssysv_aasen.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ssysv_aasen.f">
*> [TXT]</a>
-*> \endhtmlonly
+*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE SSYSV_AASEN( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK,
* LWORK, INFO )
-*
+*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER N, NRHS, LDA, LDB, LWORK, INFO
* INTEGER IPIV( * )
* REAL A( LDA, * ), B( LDB, * ), WORK( * )
* ..
-*
+*
*
*> \par Purpose:
* =============
*> A = U * T * U**T, if UPLO = 'U', or
*> A = L * T * L**T, if UPLO = 'L',
*> where U (or L) is a product of permutation and unit upper (lower)
-*> triangular matrices, and T is symmetric tridiagonal. The factored
+*> triangular matrices, and T is symmetric tridiagonal. The factored
*> form of A is then used to solve the system of equations A * X = B.
*> \endverbatim
*
*> \param[out] IPIV
*> \verbatim
*> IPIV is INTEGER array, dimension (N)
-*> On exit, it contains the details of the interchanges, i.e.,
-*> the row and column k of A were interchanged with the
+*> On exit, it contains the details of the interchanges, i.e.,
+*> the row and column k of A were interchanged with the
*> row and column IPIV(k).
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*> LWORK is INTEGER
-*> The length of WORK. LWORK >= MAX(2*N, 3*N-2), and for
-*> the best performance, LWORK >= max(1,N*NB), where NB is
+*> The length of WORK. LWORK >= MAX(2*N, 3*N-2), and for
+*> the best performance, LWORK >= max(1,N*NB), where NB is
*> the optimal blocksize for SSYTRF_AASEN.
*>
*> If LWORK = -1, then a workspace query is assumed; the routine
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
*> \date November 2016
*
*
* =========== DOCUMENTATION ===========
*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
-*> Download SSYTRF_AASEN + dependencies
-*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ssytrf_aasen.f">
-*> [TGZ]</a>
-*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ssytrf_aasen.f">
-*> [ZIP]</a>
-*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ssytrf_aasen.f">
+*> Download SSYTRF_AASEN + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ssytrf_aasen.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ssytrf_aasen.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ssytrf_aasen.f">
*> [TXT]</a>
-*> \endhtmlonly
+*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE SSYTRF_AASEN( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )
-*
+*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER N, LDA, LWORK, INFO
*> triangular part of A is not referenced.
*>
*> On exit, the tridiagonal matrix is stored in the diagonals
-*> and the subdiagonals of A just below (or above) the diagonals,
+*> and the subdiagonals of A just below (or above) the diagonals,
*> and L is stored below (or above) the subdiaonals, when UPLO
*> is 'L' (or 'U').
*> \endverbatim
*> \param[out] IPIV
*> \verbatim
*> IPIV is INTEGER array, dimension (N)
-*> On exit, it contains the details of the interchanges, i.e.,
-*> the row and column k of A were interchanged with the
+*> On exit, it contains the details of the interchanges, i.e.,
+*> the row and column k of A were interchanged with the
*> row and column IPIV(k).
*> \endverbatim
*>
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
*> \date November 2016
*
*
J = 0
10 CONTINUE
- IF( J.GE.N )
+ IF( J.GE.N )
$ GO TO 20
*
* each step of the main loop
* J is the last column of the previous panel
* J1 is the first column of the current panel
* K1 identifies if the previous column of the panel has been
-* explicitly stored, e.g., K1=1 for the first panel, and
+* explicitly stored, e.g., K1=1 for the first panel, and
* K1=0 for the rest
*
J1 = J + 1
*
* Panel factorization
*
- CALL SLASYF_AASEN( UPLO, 2-K1, N-J, JB,
+ CALL SLASYF_AASEN( UPLO, 2-K1, N-J, JB,
$ A( MAX(1, J), J+1 ), LDA,
- $ IPIV( J+1 ), WORK, N, WORK( N*NB+1 ),
+ $ IPIV( J+1 ), WORK, N, WORK( N*NB+1 ),
$ IINFO )
IF( (IINFO.GT.0) .AND. (INFO.EQ.0) ) THEN
INFO = IINFO+J
- ENDIF
+ ENDIF
*
* Ajust IPIV and apply it back (J-th step picks (J+1)-th pivot)
*
DO J2 = J+2, MIN(N, J+JB+1)
IPIV( J2 ) = IPIV( J2 ) + J
IF( (J2.NE.IPIV(J2)) .AND. ((J1-K1).GT.2) ) THEN
- CALL SSWAP( J1-K1-2, A( 1, J2 ), 1,
+ CALL SSWAP( J1-K1-2, A( 1, J2 ), 1,
$ A( 1, IPIV(J2) ), 1 )
END IF
END DO
J = J + JB
*
* Trailing submatrix update, where
-* the row A(J1-1, J2-1:N) stores U(J1, J2+1:N) and
+* the row A(J1-1, J2-1:N) stores U(J1, J2+1:N) and
* WORK stores the current block of the auxiriarly matrix H
*
IF( J.LT.N ) THEN
*
ALPHA = A( J, J+1 )
A( J, J+1 ) = ONE
- CALL SCOPY( N-J, A( J-1, J+1 ), LDA,
+ CALL SCOPY( N-J, A( J-1, J+1 ), LDA,
$ WORK( (J+1-J1+1)+JB*N ), 1 )
CALL SSCAL( N-J, ALPHA, WORK( (J+1-J1+1)+JB*N ), 1 )
*
* K1 identifies if the previous column of the panel has been
-* explicitly stored, e.g., K1=1 and K2= 0 for the first panel,
+* explicitly stored, e.g., K1=1 and K2= 0 for the first panel,
* while K1=0 and K2=1 for the rest
*
IF( J1.GT.1 ) THEN
* Not first panel
*
K2 = 1
- ELSE
+ ELSE
*
* First panel
*
K2 = 0
*
-* First update skips the first column
+* First update skips the first column
*
JB = JB - 1
END IF
*
* Update off-diagonal block of J2-th block row with SGEMM
*
- CALL SGEMM( 'Transpose', 'Transpose',
+ CALL SGEMM( 'Transpose', 'Transpose',
$ NJ, N-J3+1, JB+1,
$ -ONE, A( J1-K2, J2 ), LDA,
$ WORK( J3-J1+1+K1*N ), N,
* Factorize A as L*D*L**T using the lower triangle of A
* .....................................................
*
-* copy first column A(1:N, 1) into H(1:N, 1)
+* copy first column A(1:N, 1) into H(1:N, 1)
* (stored in WORK(1:N))
*
CALL SCOPY( N, A( 1, 1 ), 1, WORK( 1 ), 1 )
*
J = 0
11 CONTINUE
- IF( J.GE.N )
+ IF( J.GE.N )
$ GO TO 20
*
* each step of the main loop
* J is the last column of the previous panel
* J1 is the first column of the current panel
* K1 identifies if the previous column of the panel has been
-* explicitly stored, e.g., K1=1 for the first panel, and
+* explicitly stored, e.g., K1=1 for the first panel, and
* K1=0 for the rest
*
J1 = J+1
*
* Panel factorization
*
- CALL SLASYF_AASEN( UPLO, 2-K1, N-J, JB,
+ CALL SLASYF_AASEN( UPLO, 2-K1, N-J, JB,
$ A( J+1, MAX(1, J) ), LDA,
$ IPIV( J+1 ), WORK, N, WORK( N*NB+1 ), IINFO)
IF( (IINFO.GT.0) .AND. (INFO.EQ.0) ) THEN
INFO = IINFO+J
- ENDIF
+ ENDIF
*
* Ajust IPIV and apply it back (J-th step picks (J+1)-th pivot)
*
DO J2 = J+2, MIN(N, J+JB+1)
IPIV( J2 ) = IPIV( J2 ) + J
IF( (J2.NE.IPIV(J2)) .AND. ((J1-K1).GT.2) ) THEN
- CALL SSWAP( J1-K1-2, A( J2, 1 ), LDA,
+ CALL SSWAP( J1-K1-2, A( J2, 1 ), LDA,
$ A( IPIV(J2), 1 ), LDA )
END IF
END DO
J = J + JB
*
* Trailing submatrix update, where
-* A(J2+1, J1-1) stores L(J2+1, J1) and
+* A(J2+1, J1-1) stores L(J2+1, J1) and
* WORK(J2+1, 1) stores H(J2+1, 1)
*
IF( J.LT.N ) THEN
*
ALPHA = A( J+1, J )
A( J+1, J ) = ONE
- CALL SCOPY( N-J, A( J+1, J-1 ), 1,
+ CALL SCOPY( N-J, A( J+1, J-1 ), 1,
$ WORK( (J+1-J1+1)+JB*N ), 1 )
CALL SSCAL( N-J, ALPHA, WORK( (J+1-J1+1)+JB*N ), 1 )
*
* K1 identifies if the previous column of the panel has been
-* explicitly stored, e.g., K1=1 and K2= 0 for the first panel,
+* explicitly stored, e.g., K1=1 and K2= 0 for the first panel,
* while K1=0 and K2=1 for the rest
*
IF( J1.GT.1 ) THEN
*
K2 = 0
*
-* First update skips the first column
+* First update skips the first column
*
JB = JB - 1
END IF
*
* Update off-diagonal block in J2-th block column with SGEMM
*
- CALL SGEMM( 'No transpose', 'Transpose',
+ CALL SGEMM( 'No transpose', 'Transpose',
$ N-J3+1, NJ, JB+1,
$ -ONE, WORK( J3-J1+1+K1*N ), N,
$ A( J2, J1-K2 ), LDA,
*
* =========== DOCUMENTATION ===========
*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download SSYTRS_AASEN + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ssytrs_aasen.f">
-*> [TGZ]</a>
+*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ssytrs_aasen.f">
-*> [ZIP]</a>
+*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ssytrs_aasen.f">
*> [TXT]</a>
-*> \endhtmlonly
+*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE SSYTRS_AASEN( UPLO, N, NRHS, A, LDA, IPIV, B, LDB,
* WORK, LWORK, INFO )
-*
+*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER N, NRHS, LDA, LDB, LWORK, INFO
* INTEGER IPIV( * )
* REAL A( LDA, * ), B( LDB, * ), WORK( * )
* ..
-*
+*
*
*> \par Purpose:
* =============
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
*> \date November 2016
*
END IF
CALL SGTSV(N, NRHS, WORK(1), WORK(N), WORK(2*N), B, LDB,
$ INFO)
-*
+*
*
* Compute (U**T \ B) -> B [ U**T \ (T \ (U \P**T * B) ) ]
*
*
* Compute (L \P**T * B) -> B [ (L \P**T * B) ]
*
- CALL STRSM( 'L', 'L', 'N', 'U', N-1, NRHS, ONE, A( 2, 1), LDA,
+ CALL STRSM( 'L', 'L', 'N', 'U', N-1, NRHS, ONE, A( 2, 1), LDA,
$ B(2, 1), LDB)
*
* Compute T \ B -> B [ T \ (L \P**T * B) ]
$ INFO)
*
* Compute (L**T \ B) -> B [ L**T \ (T \ (L \P**T * B) ) ]
-*
+*
CALL STRSM( 'L', 'L', 'T', 'U', N-1, NRHS, ONE, A( 2, 1 ), LDA,
$ B( 2, 1 ), LDB)
*
*
* =========== DOCUMENTATION ===========
*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
-*> Download DTPQRT + dependencies
-*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/stplqt.f">
-*> [TGZ]</a>
-*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/stplqt.f">
-*> [ZIP]</a>
-*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/stplqt.f">
+*> Download DTPQRT + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/stplqt.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/stplqt.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/stplqt.f">
*> [TXT]</a>
-*> \endhtmlonly
+*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE STPLQT( M, N, L, MB, A, LDA, B, LDB, T, LDT, WORK,
* INFO )
-*
+*
* .. Scalar Arguments ..
* INTEGER INFO, LDA, LDB, LDT, N, M, L, MB
* ..
* .. Array Arguments ..
* REAL A( LDA, * ), B( LDB, * ), T( LDT, * ), WORK( * )
* ..
-*
+*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
-*> DTPLQT computes a blocked LQ factorization of a real
-*> "triangular-pentagonal" matrix C, which is composed of a
-*> triangular block A and pentagonal block B, using the compact
+*> DTPLQT computes a blocked LQ factorization of a real
+*> "triangular-pentagonal" matrix C, which is composed of a
+*> triangular block A and pentagonal block B, using the compact
*> WY representation for Q.
*> \endverbatim
*
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix B, and the order of the
-*> triangular matrix A.
+*> triangular matrix A.
*> M >= 0.
*> \endverbatim
*>
*> \param[in,out] B
*> \verbatim
*> B is REAL array, dimension (LDB,N)
-*> On entry, the pentagonal M-by-N matrix B. The first N-L columns
+*> On entry, the pentagonal M-by-N matrix B. The first N-L columns
*> are rectangular, and the last L columns are lower trapezoidal.
*> On exit, B contains the pentagonal matrix V. See Further Details.
*> \endverbatim
*> The lower triangular block reflectors stored in compact form
*> as a sequence of upper triangular blocks. See Further Details.
*> \endverbatim
-*>
+*>
*> \param[in] LDT
*> \verbatim
*> LDT is INTEGER
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
*> \date November 2013
*
*>
*> \verbatim
*>
-*> The input matrix C is a M-by-(M+N) matrix
+*> The input matrix C is a M-by-(M+N) matrix
*>
*> C = [ A ] [ B ]
-*>
+*>
*>
*> where A is an lower triangular N-by-N matrix, and B is M-by-N pentagonal
*> matrix consisting of a M-by-(N-L) rectangular matrix B1 on left of a M-by-L
*> upper trapezoidal matrix B2:
-*> [ B ] = [ B1 ] [ B2 ]
+*> [ B ] = [ B1 ] [ B2 ]
*> [ B1 ] <- M-by-(N-L) rectangular
*> [ B2 ] <- M-by-L upper trapezoidal.
*>
*> The lower trapezoidal matrix B2 consists of the first L columns of a
-*> N-by-N lower triangular matrix, where 0 <= L <= MIN(M,N). If L=0,
-*> B is rectangular M-by-N; if M=L=N, B is lower triangular.
+*> N-by-N lower triangular matrix, where 0 <= L <= MIN(M,N). If L=0,
+*> B is rectangular M-by-N; if M=L=N, B is lower triangular.
*>
*> The matrix W stores the elementary reflectors H(i) in the i-th row
*> above the diagonal (of A) in the M-by-(M+N) input matrix C
-*> [ C ] = [ A ] [ B ]
+*> [ C ] = [ A ] [ B ]
*> [ A ] <- lower triangular N-by-N
*> [ B ] <- M-by-N pentagonal
*>
*> so that W can be represented as
-*> [ W ] = [ I ] [ V ]
+*> [ W ] = [ I ] [ V ]
*> [ I ] <- identity, N-by-N
*> [ V ] <- M-by-N, same form as B.
*>
*> Thus, all of information needed for W is contained on exit in B, which
-*> we call V above. Note that V has the same form as B; that is,
-*> [ V ] = [ V1 ] [ V2 ]
+*> we call V above. Note that V has the same form as B; that is,
+*> [ V ] = [ V1 ] [ V2 ]
*> [ V1 ] <- M-by-(N-L) rectangular
*> [ V2 ] <- M-by-L lower trapezoidal.
*>
-*> The rows of V represent the vectors which define the H(i)'s.
+*> The rows of V represent the vectors which define the H(i)'s.
*>
*> The number of blocks is B = ceiling(M/MB), where each
-*> block is of order MB except for the last block, which is of order
+*> block is of order MB except for the last block, which is of order
*> IB = M - (M-1)*MB. For each of the B blocks, a upper triangular block
-*> reflector factor is computed: T1, T2, ..., TB. The MB-by-MB (and IB-by-IB
+*> reflector factor is computed: T1, T2, ..., TB. The MB-by-MB (and IB-by-IB
*> for the last block) T's are stored in the MB-by-N matrix T as
*>
*> T = [T1 T2 ... TB].
IF( M.EQ.0 .OR. N.EQ.0 ) RETURN
*
DO I = 1, M, MB
-*
+*
* Compute the QR factorization of the current block
*
IB = MIN( M-I+1, MB )
LB = NB-N+L-I+1
END IF
*
- CALL STPLQT2( IB, NB, LB, A(I,I), LDA, B( I, 1 ), LDB,
+ CALL STPLQT2( IB, NB, LB, A(I,I), LDA, B( I, 1 ), LDB,
$ T(1, I ), LDT, IINFO )
*
* Update by applying H**T to B(I+IB:M,:) from the right
*
IF( I+IB.LE.M ) THEN
CALL STPRFB( 'R', 'N', 'F', 'R', M-I-IB+1, NB, IB, LB,
- $ B( I, 1 ), LDB, T( 1, I ), LDT,
- $ A( I+IB, I ), LDA, B( I+IB, 1 ), LDB,
+ $ B( I, 1 ), LDB, T( 1, I ), LDT,
+ $ A( I+IB, I ), LDA, B( I+IB, 1 ), LDB,
$ WORK, M-I-IB+1)
END IF
END DO
RETURN
-*
+*
* End of STPLQT
*
END
*
* =========== DOCUMENTATION ===========
*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
-*> Download STPLQT2 + dependencies
-*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/stplqt2.f">
-*> [TGZ]</a>
-*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/stplqt2.f">
-*> [ZIP]</a>
-*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/stplqt2.f">
+*> Download STPLQT2 + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/stplqt2.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/stplqt2.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/stplqt2.f">
*> [TXT]</a>
-*> \endhtmlonly
+*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE STPLQT2( M, N, L, A, LDA, B, LDB, T, LDT, INFO )
-*
+*
* .. Scalar Arguments ..
* INTEGER INFO, LDA, LDB, LDT, N, M, L
* ..
* .. Array Arguments ..
* REAL A( LDA, * ), B( LDB, * ), T( LDT, * )
* ..
-*
+*
*
*> \par Purpose:
* =============
*> \verbatim
*>
*> STPLQT2 computes a LQ a factorization of a real "triangular-pentagonal"
-*> matrix C, which is composed of a triangular block A and pentagonal block B,
+*> matrix C, which is composed of a triangular block A and pentagonal block B,
*> using the compact WY representation for Q.
*> \endverbatim
*
*> \param[in] M
*> \verbatim
*> M is INTEGER
-*> The total number of rows of the matrix B.
+*> The total number of rows of the matrix B.
*> M >= 0.
*> \endverbatim
*>
*> \param[in] L
*> \verbatim
*> L is INTEGER
-*> The number of rows of the lower trapezoidal part of B.
+*> The number of rows of the lower trapezoidal part of B.
*> MIN(M,N) >= L >= 0. See Further Details.
*> \endverbatim
*>
*> \param[in,out] B
*> \verbatim
*> B is REAL array, dimension (LDB,N)
-*> On entry, the pentagonal M-by-N matrix B. The first N-L columns
+*> On entry, the pentagonal M-by-N matrix B. The first N-L columns
*> are rectangular, and the last L columns are lower trapezoidal.
*> On exit, B contains the pentagonal matrix V. See Further Details.
*> \endverbatim
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
*> \date September 2012
*
*>
*> \verbatim
*>
-*> The input matrix C is a M-by-(M+N) matrix
+*> The input matrix C is a M-by-(M+N) matrix
*>
*> C = [ A ][ B ]
-*>
+*>
*>
*> where A is an lower triangular N-by-N matrix, and B is M-by-N pentagonal
*> matrix consisting of a M-by-(N-L) rectangular matrix B1 left of a M-by-L
*> [ B2 ] <- M-by-L lower trapezoidal.
*>
*> The lower trapezoidal matrix B2 consists of the first L columns of a
-*> N-by-N lower triangular matrix, where 0 <= L <= MIN(M,N). If L=0,
-*> B is rectangular M-by-N; if M=L=N, B is lower triangular.
+*> N-by-N lower triangular matrix, where 0 <= L <= MIN(M,N). If L=0,
+*> B is rectangular M-by-N; if M=L=N, B is lower triangular.
*>
*> The matrix W stores the elementary reflectors H(i) in the i-th row
*> above the diagonal (of A) in the M-by-(M+N) input matrix C
*>
*> so that W can be represented as
*>
-*> W = [ I ][ V ]
+*> W = [ I ][ V ]
*> [ I ] <- identity, N-by-N
*> [ V ] <- M-by-N, same form as B.
*>
*> Thus, all of information needed for W is contained on exit in B, which
-*> we call V above. Note that V has the same form as B; that is,
+*> we call V above. Note that V has the same form as B; that is,
*>
-*> W = [ V1 ][ V2 ]
+*> W = [ V1 ][ V2 ]
*> [ V1 ] <- M-by-(N-L) rectangular
*> [ V2 ] <- M-by-L lower trapezoidal.
*>
-*> The rows of V represent the vectors which define the H(i)'s.
+*> The rows of V represent the vectors which define the H(i)'s.
*> The (M+N)-by-(M+N) block reflector H is then given by
*>
*> H = I - W**T * T * W
* Quick return if possible
*
IF( N.EQ.0 .OR. M.EQ.0 ) RETURN
-*
+*
DO I = 1, M
*
* Generate elementary reflector H(I) to annihilate B(I,:)
DO J = 1, M-I
T( M, J ) = (A( I+J, I ))
END DO
- CALL SGEMV( 'N', M-I, P, ONE, B( I+1, 1 ), LDB,
+ CALL SGEMV( 'N', M-I, P, ONE, B( I+1, 1 ), LDB,
$ B( I, 1 ), LDB, ONE, T( M, 1 ), LDT )
*
* C(I+1:M,I:N) = C(I+1:M,I:N) + alpha * C(I,I:N)*W(M-1:1)^H
*
- ALPHA = -(T( 1, I ))
+ ALPHA = -(T( 1, I ))
DO J = 1, M-I
A( I+J, I ) = A( I+J, I ) + ALPHA*(T( M, J ))
END DO
*
* Rectangular part of B2
*
- CALL SGEMV( 'N', I-1-P, L, ALPHA, B( MP, NP ), LDB,
+ CALL SGEMV( 'N', I-1-P, L, ALPHA, B( MP, NP ), LDB,
$ B( I, NP ), LDB, ZERO, T( I,MP ), LDT )
*
* B1
*
- CALL SGEMV( 'N', I-1, N-L, ALPHA, B, LDB, B( I, 1 ), LDB,
- $ ONE, T( I, 1 ), LDT )
+ CALL SGEMV( 'N', I-1, N-L, ALPHA, B, LDB, B( I, 1 ), LDB,
+ $ ONE, T( I, 1 ), LDT )
*
* T(1:I-1,I) := T(1:I-1,1:I-1) * T(I,1:I-1)
*
T(J,I)= ZERO
END DO
END DO
-
+
*
* End of STPLQT2
*
*
* =========== DOCUMENTATION ===========
*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
-*> Download DTPMQRT + dependencies
-*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/stpmlqt.f">
-*> [TGZ]</a>
-*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/stpmlqt.f">
-*> [ZIP]</a>
-*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/stpmlqt.f">
+*> Download DTPMQRT + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/stpmlqt.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/stpmlqt.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/stpmlqt.f">
*> [TXT]</a>
-*> \endhtmlonly
+*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE STPMLQT( SIDE, TRANS, M, N, K, L, MB, V, LDV, T, LDT,
* A, LDA, B, LDB, WORK, INFO )
-*
+*
* .. Scalar Arguments ..
* CHARACTER SIDE, TRANS
* INTEGER INFO, K, LDV, LDA, LDB, M, N, L, MB, LDT
* ..
* .. Array Arguments ..
-* REAL V( LDV, * ), A( LDA, * ), B( LDB, * ),
+* REAL V( LDV, * ), A( LDA, * ), B( LDB, * ),
* $ T( LDT, * ), WORK( * )
* ..
-*
+*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
-*> DTPMQRT applies a real orthogonal matrix Q obtained from a
+*> DTPMQRT applies a real orthogonal matrix Q obtained from a
*> "triangular-pentagonal" real block reflector H to a general
*> real matrix C, which consists of two blocks A and B.
*> \endverbatim
*> N is INTEGER
*> The number of columns of the matrix B. N >= 0.
*> \endverbatim
-*>
+*>
*> \param[in] K
*> \verbatim
*> K is INTEGER
*> \param[in] L
*> \verbatim
*> L is INTEGER
-*> The order of the trapezoidal part of V.
+*> The order of the trapezoidal part of V.
*> K >= L >= 0. See Further Details.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is REAL array, dimension
-*> (LDA,N) if SIDE = 'L' or
+*> (LDA,N) if SIDE = 'L' or
*> (LDA,K) if SIDE = 'R'
*> On entry, the K-by-N or M-by-K matrix A.
-*> On exit, A is overwritten by the corresponding block of
+*> On exit, A is overwritten by the corresponding block of
*> Q*C or Q**T*C or C*Q or C*Q**T. See Further Details.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
-*> The leading dimension of the array A.
+*> The leading dimension of the array A.
*> If SIDE = 'L', LDC >= max(1,K);
-*> If SIDE = 'R', LDC >= max(1,M).
+*> If SIDE = 'R', LDC >= max(1,M).
*> \endverbatim
*>
*> \param[in,out] B
*> \param[in] LDB
*> \verbatim
*> LDB is INTEGER
-*> The leading dimension of the array B.
+*> The leading dimension of the array B.
*> LDB >= max(1,M).
*> \endverbatim
*>
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
*> \date November 2015
*
*> \verbatim
*>
*> The columns of the pentagonal matrix V contain the elementary reflectors
-*> H(1), H(2), ..., H(K); V is composed of a rectangular block V1 and a
+*> H(1), H(2), ..., H(K); V is composed of a rectangular block V1 and a
*> trapezoidal block V2:
*>
*> V = [V1] [V2].
-*>
*>
-*> The size of the trapezoidal block V2 is determined by the parameter L,
+*>
+*> The size of the trapezoidal block V2 is determined by the parameter L,
*> where 0 <= L <= K; V2 is lower trapezoidal, consisting of the first L
*> rows of a K-by-K upper triangular matrix. If L=K, V2 is lower triangular;
*> if L=0, there is no trapezoidal block, hence V = V1 is rectangular.
*>
-*> If SIDE = 'L': C = [A] where A is K-by-N, B is M-by-N and V is K-by-M.
-*> [B]
-*>
+*> If SIDE = 'L': C = [A] where A is K-by-N, B is M-by-N and V is K-by-M.
+*> [B]
+*>
*> If SIDE = 'R': C = [A B] where A is M-by-K, B is M-by-N and V is K-by-N.
*>
*> The real orthogonal matrix Q is formed from V and T.
INTEGER INFO, K, LDV, LDA, LDB, M, N, L, MB, LDT
* ..
* .. Array Arguments ..
- REAL V( LDV, * ), A( LDA, * ), B( LDB, * ),
+ REAL V( LDV, * ), A( LDA, * ), B( LDB, * ),
$ T( LDT, * ), WORK( * )
* ..
*
RIGHT = LSAME( SIDE, 'R' )
TRAN = LSAME( TRANS, 'T' )
NOTRAN = LSAME( TRANS, 'N' )
-*
+*
IF ( LEFT ) THEN
LDAQ = MAX( 1, K )
ELSE IF ( RIGHT ) THEN
ELSE IF( K.LT.0 ) THEN
INFO = -5
ELSE IF( L.LT.0 .OR. L.GT.K ) THEN
- INFO = -6
+ INFO = -6
ELSE IF( MB.LT.1 .OR. (MB.GT.K .AND. K.GT.0) ) THEN
INFO = -7
ELSE IF( LDV.LT.K ) THEN
ELSE
LB = 0
END IF
- CALL STPRFB( 'L', 'T', 'F', 'R', NB, N, IB, LB,
- $ V( I, 1 ), LDV, T( 1, I ), LDT,
+ CALL STPRFB( 'L', 'T', 'F', 'R', NB, N, IB, LB,
+ $ V( I, 1 ), LDV, T( 1, I ), LDT,
$ A( I, 1 ), LDA, B, LDB, WORK, IB )
END DO
-*
+*
ELSE IF( RIGHT .AND. TRAN ) THEN
*
DO I = 1, K, MB
ELSE
LB = NB-N+L-I+1
END IF
- CALL STPRFB( 'R', 'N', 'F', 'R', M, NB, IB, LB,
- $ V( I, 1 ), LDV, T( 1, I ), LDT,
+ CALL STPRFB( 'R', 'N', 'F', 'R', M, NB, IB, LB,
+ $ V( I, 1 ), LDV, T( 1, I ), LDT,
$ A( 1, I ), LDA, B, LDB, WORK, M )
END DO
*
*
KF = ((K-1)/MB)*MB+1
DO I = KF, 1, -MB
- IB = MIN( MB, K-I+1 )
+ IB = MIN( MB, K-I+1 )
NB = MIN( M-L+I+IB-1, M )
IF( I.GE.L ) THEN
LB = 0
ELSE
LB = 0
- END IF
+ END IF
CALL STPRFB( 'L', 'N', 'F', 'R', NB, N, IB, LB,
- $ V( I, 1 ), LDV, T( 1, I ), LDT,
+ $ V( I, 1 ), LDV, T( 1, I ), LDT,
$ A( I, 1 ), LDA, B, LDB, WORK, IB )
END DO
*
*
KF = ((K-1)/MB)*MB+1
DO I = KF, 1, -MB
- IB = MIN( MB, K-I+1 )
+ IB = MIN( MB, K-I+1 )
NB = MIN( N-L+I+IB-1, N )
IF( I.GE.L ) THEN
LB = 0
LB = NB-N+L-I+1
END IF
CALL STPRFB( 'R', 'T', 'F', 'R', M, NB, IB, LB,
- $ V( I, 1 ), LDV, T( 1, I ), LDT,
+ $ V( I, 1 ), LDV, T( 1, I ), LDT,
$ A( 1, I ), LDA, B, LDB, WORK, M )
END DO
*
-*
+*
* Definition:
* ===========
*
-* SUBROUTINE CGELQ( M, N, A, LDA, WORK1, LWORK1, WORK2, LWORK2,
+* SUBROUTINE CGELQ( M, N, A, LDA, WORK1, LWORK1, WORK2, LWORK2,
* INFO)
-*
+*
* .. Scalar Arguments ..
* INTEGER INFO, LDA, M, N, LWORK1, LWORK2
* ..
* .. Array Arguments ..
* COMPLEX*16 A( LDA, * ), WORK1( * ), WORK2( * )
* ..
-*
+*
*
*> \par Purpose:
* =============
*>
*> \verbatim
-*>
-*> ZGELQ computes an LQ factorization of an M-by-N matrix A,
-*> using ZLASWLQ when A is short and wide
-*> (N sufficiently greater than M), and otherwise ZGELQT:
+*>
+*> ZGELQ computes an LQ factorization of an M-by-N matrix A,
+*> using ZLASWLQ when A is short and wide
+*> (N sufficiently greater than M), and otherwise ZGELQT:
*> A = L * Q .
*> \endverbatim
*
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> On entry, the M-by-N matrix A.
-*> On exit, the elements on and below the diagonal of the array
-*> contain the M-by-min(M,N) lower trapezoidal matrix L
+*> On exit, the elements on and below the diagonal of the array
+*> contain the M-by-min(M,N) lower trapezoidal matrix L
*> (L is lower triangular if M <= N);
-*> the elements above the diagonal are the rows of
+*> the elements above the diagonal are the rows of
*> blocked V representing Q (see Further Details).
*> \endverbatim
*>
*> \verbatim
*> WORK1 is COMPLEX*16 array, dimension (MAX(1,LWORK1))
*> WORK1 contains part of the data structure used to store Q.
-*> WORK1(1): algorithm type = 1, to indicate output from
+*> WORK1(1): algorithm type = 1, to indicate output from
*> ZLASWLQ or ZGELQT
*> WORK1(2): optimum size of WORK1
*> WORK1(3): minimum size of WORK1
*> WORK1(4): horizontal block size
*> WORK1(5): vertical block size
-*> WORK1(6:LWORK1): data structure needed for Q, computed by
+*> WORK1(6:LWORK1): data structure needed for Q, computed by
*> ZLASWLQ or ZGELQT
*> \endverbatim
*>
*> \verbatim
*> LWORK1 is INTEGER
*> The dimension of the array WORK1.
-*> If LWORK1 = -1, then a query is assumed. In this case the
+*> If LWORK1 = -1, then a query is assumed. In this case the
*> routine calculates the optimal size of WORK1 and
-*> returns this value in WORK1(2), and calculates the minimum
-*> size of WORK1 and returns this value in WORK1(3).
-*> No error message related to LWORK1 is issued by XERBLA when
+*> returns this value in WORK1(2), and calculates the minimum
+*> size of WORK1 and returns this value in WORK1(3).
+*> No error message related to LWORK1 is issued by XERBLA when
*> LWORK1 = -1.
*> \endverbatim
*>
*> \param[out] WORK2
*> \verbatim
*> (workspace) COMPLEX*16 array, dimension (MAX(1,LWORK2))
-*>
+*>
*> \endverbatim
*> \param[in] LWORK2
*> \verbatim
*> LWORK2 is INTEGER
*> The dimension of the array WORK2.
*> If LWORK2 = -1, then a query is assumed. In this case the
-*> routine calculates the optimal size of WORK2 and
+*> routine calculates the optimal size of WORK2 and
*> returns this value in WORK2(1), and calculates the minimum
*> size of WORK2 and returns this value in WORK2(2).
*> No error message related to LWORK2 is issued by XERBLA when
*> Depending on the matrix dimensions M and N, and row and column
*> block sizes MB and NB returned by ILAENV, GELQ will use either
*> LASWLQ(if the matrix is short-and-wide) or GELQT to compute
-*> the LQ decomposition.
+*> the LQ decomposition.
*> The output of LASWLQ or GELQT representing Q is stored in A and in
-*> array WORK1(6:LWORK1) for later use.
-*> WORK1(2:5) contains the matrix dimensions M,N and block sizes MB, NB
-*> which are needed to interpret A and WORK1(6:LWORK1) for later use.
-*> WORK1(1)=1 indicates that the code needed to take WORK1(2:5) and
+*> array WORK1(6:LWORK1) for later use.
+*> WORK1(2:5) contains the matrix dimensions M,N and block sizes MB, NB
+*> which are needed to interpret A and WORK1(6:LWORK1) for later use.
+*> WORK1(1)=1 indicates that the code needed to take WORK1(2:5) and
*> decide whether LASWLQ or GELQT was used is the same as used below in
-*> GELQ. For a detailed description of A and WORK1(6:LWORK1), see
+*> GELQ. For a detailed description of A and WORK1(6:LWORK1), see
*> Further Details in LASWLQ or GELQT.
*> \endverbatim
*>
* =====================================================================
- SUBROUTINE ZGELQ( M, N, A, LDA, WORK1, LWORK1, WORK2, LWORK2,
+ SUBROUTINE ZGELQ( M, N, A, LDA, WORK1, LWORK1, WORK2, LWORK2,
$ INFO)
*
* -- LAPACK computational routine (version 3.5.0) --
*
LQUERY = ( LWORK1.EQ.-1 .OR. LWORK2.EQ.-1 )
*
-* Determine the block size
-*
+* Determine the block size
+*
IF ( MIN(M,N).GT.0 ) THEN
MB = ILAENV( 1, 'ZGELQ ', ' ', M, N, 1, -1)
NB = ILAENV( 1, 'ZGELQ ', ' ', M, N, 2, -1)
END IF
*
* Determine if the workspace size satisfies minimum size
-*
- LMINWS = .FALSE.
+*
+ LMINWS = .FALSE.
IF((LWORK1.LT.MAX(1,MB*M*NBLCKS+5)
$ .OR.(LWORK2.LT.MB*M)).AND.(LWORK2.GE.M).AND.(LWORK1.GE.M+5)
$ .AND.(.NOT.LQUERY)) THEN
IF (LWORK1.LT.MAX(1,MB*M*NBLCKS+5)) THEN
LMINWS = .TRUE.
MB = 1
- END IF
+ END IF
IF (LWORK1.LT.MAX(1,M*NBLCKS+5)) THEN
LMINWS = .TRUE.
- NB = N
+ NB = N
END IF
IF (LWORK2.LT.MB*M) THEN
LMINWS = .TRUE.
INFO = -2
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -4
- ELSE IF( LWORK1.LT.MAX( 1, MB*M*NBLCKS+5 )
+ ELSE IF( LWORK1.LT.MAX( 1, MB*M*NBLCKS+5 )
$ .AND.(.NOT.LQUERY).AND. (.NOT.LMINWS)) THEN
INFO = -6
ELSE IF( (LWORK2.LT.MAX(1,M*MB)).AND.(.NOT.LQUERY)
$ .AND.(.NOT.LMINWS) ) THEN
- INFO = -8
- END IF
+ INFO = -8
+ END IF
*
IF( INFO.EQ.0) THEN
WORK1(1) = 1
*
IF((N.LE.M).OR.(NB.LE.M).OR.(NB.GE.N)) THEN
CALL ZGELQT( M, N, MB, A, LDA, WORK1(6), MB, WORK2, INFO)
- ELSE
- CALL ZLASWLQ( M, N, MB, NB, A, LDA, WORK1(6), MB, WORK2,
+ ELSE
+ CALL ZLASWLQ( M, N, MB, NB, A, LDA, WORK1(6), MB, WORK2,
$ LWORK2, INFO)
END IF
RETURN
-*
+*
* End of ZGELQ
*
- END
\ No newline at end of file
+ END
*
* =========== DOCUMENTATION ===========
*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
-*> Download DGEQRT + dependencies
-*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zgelqt.f">
-*> [TGZ]</a>
-*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zgelqt.f">
-*> [ZIP]</a>
-*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zgelqt.f">
+*> Download DGEQRT + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zgelqt.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zgelqt.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zgelqt.f">
*> [TXT]</a>
-*> \endhtmlonly
+*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZGELQT( M, N, MB, A, LDA, T, LDT, WORK, INFO )
-*
+*
* .. Scalar Arguments ..
* INTEGER INFO, LDA, LDT, M, N, MB
* ..
* .. Array Arguments ..
* COMPLEX*16 A( LDA, * ), T( LDT, * ), WORK( * )
* ..
-*
+*
*
*> \par Purpose:
* =============
*> \verbatim
*>
*> ZGELQT computes a blocked LQ factorization of a complex M-by-N matrix A
-*> using the compact WY representation of Q.
+*> using the compact WY representation of Q.
*> \endverbatim
*
* Arguments:
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
*> \date November 2013
*
*> V = ( 1 v1 v1 v1 v1 )
*> ( 1 v2 v2 v2 )
*> ( 1 v3 v3 )
-*>
+*>
*>
*> where the vi's represent the vectors which define H(i), which are returned
-*> in the matrix A. The 1's along the diagonal of V are not stored in A.
+*> in the matrix A. The 1's along the diagonal of V are not stored in A.
*> Let K=MIN(M,N). The number of blocks is B = ceiling(K/NB), where each
-*> block is of order NB except for the last block, which is of order
+*> block is of order NB except for the last block, which is of order
*> IB = K - (B-1)*NB. For each of the B blocks, a upper triangular block
-*> reflector factor is computed: T1, T2, ..., TB. The NB-by-NB (and IB-by-IB
+*> reflector factor is computed: T1, T2, ..., TB. The NB-by-NB (and IB-by-IB
*> for the last block) T's are stored in the NB-by-N matrix T as
*>
*> T = (T1 T2 ... TB).
*
DO I = 1, K, MB
IB = MIN( K-I+1, MB )
-*
+*
* Compute the LQ factorization of the current block A(I:M,I:I+IB-1)
-*
+*
CALL ZGELQT3( IB, N-I+1, A(I,I), LDA, T(1,I), LDT, IINFO )
IF( I+IB.LE.M ) THEN
*
* Update by applying H**T to A(I:M,I+IB:N) from the right
*
CALL ZLARFB( 'R', 'N', 'F', 'R', M-I-IB+1, N-I+1, IB,
- $ A( I, I ), LDA, T( 1, I ), LDT,
+ $ A( I, I ), LDA, T( 1, I ), LDT,
$ A( I+IB, I ), LDA, WORK , M-I-IB+1 )
END IF
END DO
RETURN
-*
+*
* End of ZGELQT
*
END
-*
+*
* Definition:
* ===========
*
-* SUBROUTINE ZGEMLQ( SIDE, TRANS, M, N, K, A, LDA, WORK1,
+* SUBROUTINE ZGEMLQ( SIDE, TRANS, M, N, K, A, LDA, WORK1,
* $ LWORK1, C, LDC, WORK2, LWORK2, INFO )
*
*
* =============
*>
*> \verbatim
-*>
+*>
*> ZGEMLQ overwrites the general real M-by-N matrix C with
*>
-*>
+*>
*> SIDE = 'L' SIDE = 'R'
*> TRANS = 'N': Q * C C * Q
*> TRANS = 'T': Q**T * C C * Q**T
-*> where Q is a complex orthogonal matrix defined as the product
-*> of blocked elementary reflectors computed by short wide LQ
+*> where Q is a complex orthogonal matrix defined as the product
+*> of blocked elementary reflectors computed by short wide LQ
*> factorization (DGELQ)
*> \endverbatim
*
*> The number of elementary reflectors whose product defines
*> the matrix Q.
*> M >= K >= 0;
-*>
+*>
*> \endverbatim
*>
*> \param[in,out] A
*> \param[out] WORK2
*> \verbatim
*> (workspace) COMPLEX*16 array, dimension (MAX(1,LWORK2))
-*>
+*>
*> \endverbatim
*> \param[in] LWORK2
*> \verbatim
*> LWORK2 is INTEGER
-*> The dimension of the array WORK2.
+*> The dimension of the array WORK2.
*> If LWORK2 = -1, then a workspace query is assumed; the routine
*> only calculates the optimal size of the WORK2 array, returns
-*> this value as the third entry of the WORK2 array (WORK2(1)),
+*> this value as the third entry of the WORK2 array (WORK2(1)),
*> and no error message related to LWORK2 is issued by XERBLA.
*>
*> \endverbatim
*> Depending on the matrix dimensions M and N, and row and column
*> block sizes MB and NB returned by ILAENV, GELQ will use either
*> LASWLQ(if the matrix is short-and-wide) or GELQT to compute
-*> the LQ decomposition.
+*> the LQ decomposition.
*> The output of LASWLQ or GELQT representing Q is stored in A and in
-*> array WORK1(6:LWORK1) for later use.
-*> WORK1(2:5) contains the matrix dimensions M,N and block sizes MB, NB
-*> which are needed to interpret A and WORK1(6:LWORK1) for later use.
-*> WORK1(1)=1 indicates that the code needed to take WORK1(2:5) and
+*> array WORK1(6:LWORK1) for later use.
+*> WORK1(2:5) contains the matrix dimensions M,N and block sizes MB, NB
+*> which are needed to interpret A and WORK1(6:LWORK1) for later use.
+*> WORK1(1)=1 indicates that the code needed to take WORK1(2:5) and
*> decide whether LASWLQ or GELQT was used is the same as used below in
-*> GELQ. For a detailed description of A and WORK1(6:LWORK1), see
+*> GELQ. For a detailed description of A and WORK1(6:LWORK1), see
*> Further Details in LASWLQ or GELQT.
*> \endverbatim
*>
* =====================================================================
- SUBROUTINE ZGEMLQ( SIDE, TRANS, M, N, K, A, LDA, WORK1, LWORK1,
+ SUBROUTINE ZGEMLQ( SIDE, TRANS, M, N, K, A, LDA, WORK1, LWORK1,
$ C, LDC, WORK2, LWORK2, INFO )
*
* -- LAPACK computational routine (version 3.5.0) --
*
IF( MIN(M,N,K).EQ.0 ) THEN
RETURN
- END IF
+ END IF
*
IF((LEFT.AND.M.LE.K).OR.(RIGHT.AND.N.LE.K).OR.(NB.LE.K).OR.
$ (NB.GE.MAX(M,N,K))) THEN
- CALL ZGEMLQT( SIDE, TRANS, M, N, K, MB, A, LDA,
- $ WORK1(6), MB, C, LDC, WORK2, INFO)
+ CALL ZGEMLQT( SIDE, TRANS, M, N, K, MB, A, LDA,
+ $ WORK1(6), MB, C, LDC, WORK2, INFO)
ELSE
CALL ZLAMSWLQ( SIDE, TRANS, M, N, K, MB, NB, A, LDA, WORK1(6),
$ MB, C, LDC, WORK2, LWORK2, INFO )
*
* End of ZGEMLQ
*
- END
\ No newline at end of file
+ END
*
* =========== DOCUMENTATION ===========
*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
-*> Download DGEMQRT + dependencies
-*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zgemlqt.f">
-*> [TGZ]</a>
-*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zgemlqt.f">
-*> [ZIP]</a>
-*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zgemlqt.f">
+*> Download DGEMQRT + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zgemlqt.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zgemlqt.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zgemlqt.f">
*> [TXT]</a>
-*> \endhtmlonly
+*> \endhtmlonly
*
* Definition:
* ===========
*
-* SUBROUTINE ZGEMLQT( SIDE, TRANS, M, N, K, MB, V, LDV, T, LDT,
+* SUBROUTINE ZGEMLQT( SIDE, TRANS, M, N, K, MB, V, LDV, T, LDT,
* C, LDC, WORK, INFO )
-*
+*
* .. Scalar Arguments ..
* CHARACTER SIDE, TRANS
* INTEGER INFO, K, LDV, LDC, M, N, MB, LDT
* .. Array Arguments ..
* DOUBLE PRECISION V( LDV, * ), C( LDC, * ), T( LDT, * ), WORK( * )
* ..
-*
+*
*
*> \par Purpose:
* =============
*>
*> Q = H(1) H(2) . . . H(K) = I - V C V**C
*>
-*> generated using the compact WY representation as returned by ZGELQT.
+*> generated using the compact WY representation as returned by ZGELQT.
*>
*> Q is of order M if SIDE = 'L' and of order N if SIDE = 'R'.
*> \endverbatim
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
*> \date November 2013
*
*> \ingroup doubleGEcomputational
*
* =====================================================================
- SUBROUTINE ZGEMLQT( SIDE, TRANS, M, N, K, MB, V, LDV, T, LDT,
+ SUBROUTINE ZGEMLQT( SIDE, TRANS, M, N, K, MB, V, LDV, T, LDT,
$ C, LDC, WORK, INFO )
*
* -- LAPACK computational routine (version 3.5.0) --
RIGHT = LSAME( SIDE, 'R' )
TRAN = LSAME( TRANS, 'C' )
NOTRAN = LSAME( TRANS, 'N' )
-*
+*
IF( LEFT ) THEN
LDWORK = MAX( 1, N )
ELSE IF ( RIGHT ) THEN
*
DO I = 1, K, MB
IB = MIN( MB, K-I+1 )
- CALL ZLARFB( 'L', 'C', 'F', 'R', M-I+1, N, IB,
- $ V( I, I ), LDV, T( 1, I ), LDT,
+ CALL ZLARFB( 'L', 'C', 'F', 'R', M-I+1, N, IB,
+ $ V( I, I ), LDV, T( 1, I ), LDT,
$ C( I, 1 ), LDC, WORK, LDWORK )
END DO
-*
+*
ELSE IF( RIGHT .AND. TRAN ) THEN
*
DO I = 1, K, MB
IB = MIN( MB, K-I+1 )
- CALL ZLARFB( 'R', 'N', 'F', 'R', M, N-I+1, IB,
- $ V( I, I ), LDV, T( 1, I ), LDT,
+ CALL ZLARFB( 'R', 'N', 'F', 'R', M, N-I+1, IB,
+ $ V( I, I ), LDV, T( 1, I ), LDT,
$ C( 1, I ), LDC, WORK, LDWORK )
END DO
*
*
KF = ((K-1)/MB)*MB+1
DO I = KF, 1, -MB
- IB = MIN( MB, K-I+1 )
- CALL ZLARFB( 'L', 'N', 'F', 'R', M-I+1, N, IB,
- $ V( I, I ), LDV, T( 1, I ), LDT,
+ IB = MIN( MB, K-I+1 )
+ CALL ZLARFB( 'L', 'N', 'F', 'R', M-I+1, N, IB,
+ $ V( I, I ), LDV, T( 1, I ), LDT,
$ C( I, 1 ), LDC, WORK, LDWORK )
END DO
*
*
KF = ((K-1)/MB)*MB+1
DO I = KF, 1, -MB
- IB = MIN( MB, K-I+1 )
- CALL ZLARFB( 'R', 'C', 'F', 'R', M, N-I+1, IB,
- $ V( I, I ), LDV, T( 1, I ), LDT,
+ IB = MIN( MB, K-I+1 )
+ CALL ZLARFB( 'R', 'C', 'F', 'R', M, N-I+1, IB,
+ $ V( I, I ), LDV, T( 1, I ), LDT,
$ C( 1, I ), LDC, WORK, LDWORK )
END DO
*
-*
+*
* Definition:
* ===========
*
-* SUBROUTINE ZGEMQR( SIDE, TRANS, M, N, K, A, LDA, WORK1,
+* SUBROUTINE ZGEMQR( SIDE, TRANS, M, N, K, A, LDA, WORK1,
* $ LWORK1, C, LDC, WORK2, LWORK2, INFO )
*
*
* =============
*>
*> \verbatim
-*>
+*>
*> ZGEMQR overwrites the general real M-by-N matrix C with
*>
-*>
+*>
*> SIDE = 'L' SIDE = 'R'
*> TRANS = 'N': Q * C C * Q
*> TRANS = 'T': Q**T * C C * Q**T
-*> where Q is a complex orthogonal matrix defined as the product
-*> of blocked elementary reflectors computed by tall skinny
+*> where Q is a complex orthogonal matrix defined as the product
+*> of blocked elementary reflectors computed by tall skinny
*> QR factorization (ZGEQR)
*> \endverbatim
*
*> 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,K)
-*> The i-th column must contain the vector which defines the
-*> blockedelementary reflector H(i), for i = 1,2,...,k, as
-*> returned by DGETSQR in the first k columns of
+*> The i-th column must contain the vector which defines the
+*> blockedelementary reflector H(i), for i = 1,2,...,k, as
+*> returned by DGETSQR in the first k columns of
*> its array argument A.
*> \endverbatim
*>
*> \param[out] WORK2
*> \verbatim
*> (workspace) COMPLEX*16 array, dimension (MAX(1,LWORK2))
-*>
+*>
*> \endverbatim
*> \param[in] LWORK2
*> \verbatim
*> LWORK2 is INTEGER
-*> The dimension of the array WORK2.
+*> The dimension of the array WORK2.
*> If LWORK2 = -1, then a workspace query is assumed; the routine
*> only calculates the optimal size of the WORK2 array, returns
-*> this value as the third entry of the WORK2 array (WORK2(1)),
+*> this value as the third entry of the WORK2 array (WORK2(1)),
*> and no error message related to LWORK2 is issued by XERBLA.
*>
*> \endverbatim
*> Depending on the matrix dimensions M and N, and row and column
*> block sizes MB and NB returned by ILAENV, GEQR will use either
*> LATSQR (if the matrix is tall-and-skinny) or GEQRT to compute
-*> the QR decomposition.
+*> the QR decomposition.
*> The output of LATSQR or GEQRT representing Q is stored in A and in
-*> array WORK1(6:LWORK1) for later use.
-*> WORK1(2:5) contains the matrix dimensions M,N and block sizes MB,NB
-*> which are needed to interpret A and WORK1(6:LWORK1) for later use.
-*> WORK1(1)=1 indicates that the code needed to take WORK1(2:5) and
-*> decide whether LATSQR or GEQRT was used is the same as used below in
+*> array WORK1(6:LWORK1) for later use.
+*> WORK1(2:5) contains the matrix dimensions M,N and block sizes MB,NB
+*> which are needed to interpret A and WORK1(6:LWORK1) for later use.
+*> WORK1(1)=1 indicates that the code needed to take WORK1(2:5) and
+*> decide whether LATSQR or GEQRT was used is the same as used below in
*> GEQR. For a detailed description of A and WORK1(6:LWORK1), see
*> Further Details in LATSQR or GEQRT.
*> \endverbatim
*>
* =====================================================================
- SUBROUTINE ZGEMQR( SIDE, TRANS, M, N, K, A, LDA, WORK1, LWORK1,
+ SUBROUTINE ZGEMQR( SIDE, TRANS, M, N, K, A, LDA, WORK1, LWORK1,
$ C, LDC, WORK2, LWORK2, INFO )
*
* -- LAPACK computational routine (version 3.5.0) --
LOGICAL LSAME
EXTERNAL LSAME
* .. External Subroutines ..
- EXTERNAL ZGEMQRT, ZLAMTSQR, XERBLA
+ EXTERNAL ZGEMQRT, ZLAMTSQR, XERBLA
* .. Intrinsic Functions ..
INTRINSIC INT, MAX, MIN, MOD
* ..
ELSE IF(RIGHT) THEN
LW = MB * NB
MN = N
- END IF
+ END IF
*
IF ((MB.GT.K).AND.(MN.GT.K)) THEN
IF(MOD(MN-K, MB-K).EQ.0) THEN
END IF
*
* Determine the block size if it is tall skinny or short and wide
-*
+*
IF( INFO.EQ.0) THEN
- WORK2(1) = LW
+ WORK2(1) = LW
END IF
*
IF( INFO.NE.0 ) THEN
*
IF((LEFT.AND.M.LE.K).OR.(RIGHT.AND.N.LE.K).OR.(MB.LE.K).OR.
$ (MB.GE.MAX(M,N,K))) THEN
- CALL ZGEMQRT( SIDE, TRANS, M, N, K, NB, A, LDA,
- $ WORK1(6), NB, C, LDC, WORK2, INFO)
+ CALL ZGEMQRT( SIDE, TRANS, M, N, K, NB, A, LDA,
+ $ WORK1(6), NB, C, LDC, WORK2, INFO)
ELSE
CALL ZLAMTSQR( SIDE, TRANS, M, N, K, MB, NB, A, LDA, WORK1(6),
$ NB, C, LDC, WORK2, LWORK2, INFO )
- END IF
+ END IF
*
- WORK2(1) = LW
+ WORK2(1) = LW
RETURN
*
* End of DGEMQR
*
- END
\ No newline at end of file
+ END
-*
+*
* Definition:
* ===========
*
* SUBROUTINE ZGEQR( M, N, A, LDA, WORK1, LWORK1, WORK2, LWORK2,
* INFO)
-*
+*
* .. Scalar Arguments ..
* INTEGER INFO, LDA, M, N, LWORK1, LWORK2
* ..
* .. Array Arguments ..
* COMPLEX*16 A( LDA, * ), WORK1( * ), WORK2( * )
* ..
-*
+*
*
*> \par Purpose:
* =============
*>
*> \verbatim
-*>
-*> ZGEQR computes a QR factorization of an M-by-N matrix A,
-*> using ZLATSQR when A is tall and skinny
-*> (M sufficiently greater than N), and otherwise ZGEQRT:
+*>
+*> ZGEQR computes a QR factorization of an M-by-N matrix A,
+*> using ZLATSQR when A is tall and skinny
+*> (M sufficiently greater than N), and otherwise ZGEQRT:
*> A = Q * R .
*> \endverbatim
*
*> A is COMPLEX*16 array, dimension (LDA,N)
*> On entry, the M-by-N matrix A.
*> On exit, the elements on and above the diagonal of the array
-*> contain the min(M,N)-by-N upper trapezoidal matrix R
+*> contain the min(M,N)-by-N upper trapezoidal matrix R
*> (R is upper triangular if M >= N);
*> the elements below the diagonal represent Q (see Further Details).
*> \endverbatim
*> \verbatim
*> WORK1 is COMPLEX*16 array, dimension (MAX(1,LWORK1))
*> WORK1 contains part of the data structure used to store Q.
-*> WORK1(1): algorithm type = 1, to indicate output from
+*> WORK1(1): algorithm type = 1, to indicate output from
*> ZLATSQR or ZGEQRT
*> WORK1(2): optimum size of WORK1
*> WORK1(3): minimum size of WORK1
*> WORK1(4): row block size
*> WORK1(5): column block size
-*> WORK1(6:LWORK1): data structure needed for Q, computed by
+*> WORK1(6:LWORK1): data structure needed for Q, computed by
*> CLATSQR or CGEQRT
*> \endverbatim
*>
*> \verbatim
*> LWORK1 is INTEGER
*> The dimension of the array WORK1.
-*> If LWORK1 = -1, then a query is assumed. In this case the
+*> If LWORK1 = -1, then a query is assumed. In this case the
*> routine calculates the optimal size of WORK1 and
-*> returns this value in WORK1(2), and calculates the minimum
-*> size of WORK1 and returns this value in WORK1(3).
-*> No error message related to LWORK1 is issued by XERBLA when
+*> returns this value in WORK1(2), and calculates the minimum
+*> size of WORK1 and returns this value in WORK1(3).
+*> No error message related to LWORK1 is issued by XERBLA when
*> LWORK1 = -1.
*> \endverbatim
*>
*> \param[out] WORK2
*> \verbatim
-*> (workspace) COMPLEX*16 array, dimension (MAX(1,LWORK2))
+*> (workspace) COMPLEX*16 array, dimension (MAX(1,LWORK2))
*> \endverbatim
*>
*> \param[in] LWORK2
*> \verbatim
*> LWORK2 is INTEGER
*> The dimension of the array WORK2.
-*> If LWORK2 = -1, then a query is assumed. In this case the
-*> routine calculates the optimal size of WORK2 and
+*> If LWORK2 = -1, then a query is assumed. In this case the
+*> routine calculates the optimal size of WORK2 and
*> returns this value in WORK2(1), and calculates the minimum
*> size of WORK2 and returns this value in WORK2(2).
*> No error message related to LWORK2 is issued by XERBLA when
*> Depending on the matrix dimensions M and N, and row and column
*> block sizes MB and NB returned by ILAENV, GEQR will use either
*> LATSQR (if the matrix is tall-and-skinny) or GEQRT to compute
-*> the QR decomposition.
+*> the QR decomposition.
*> The output of LATSQR or GEQRT representing Q is stored in A and in
-*> array WORK1(6:LWORK1) for later use.
-*> WORK1(2:5) contains the matrix dimensions M,N and block sizes MB,NB
-*> which are needed to interpret A and WORK1(6:LWORK1) for later use.
-*> WORK1(1)=1 indicates that the code needed to take WORK1(2:5) and
-*> decide whether LATSQR or GEQRT was used is the same as used below in
+*> array WORK1(6:LWORK1) for later use.
+*> WORK1(2:5) contains the matrix dimensions M,N and block sizes MB,NB
+*> which are needed to interpret A and WORK1(6:LWORK1) for later use.
+*> WORK1(1)=1 indicates that the code needed to take WORK1(2:5) and
+*> decide whether LATSQR or GEQRT was used is the same as used below in
*> GEQR. For a detailed description of A and WORK1(6:LWORK1), see
*> Further Details in LATSQR or GEQRT.
*> \endverbatim
*>
* =====================================================================
- SUBROUTINE ZGEQR( M, N, A, LDA, WORK1, LWORK1, WORK2, LWORK2,
+ SUBROUTINE ZGEQR( M, N, A, LDA, WORK1, LWORK1, WORK2, LWORK2,
$ INFO)
*
* -- LAPACK computational routine (version 3.5.0) --
*
LQUERY = ( LWORK1.EQ.-1 .OR. LWORK2.EQ.-1 )
*
-* Determine the block size
-*
+* Determine the block size
+*
IF ( MIN(M,N).GT.0 ) THEN
MB = ILAENV( 1, 'ZGEQR ', ' ', M, N, 1, -1)
NB = ILAENV( 1, 'ZGEQR ', ' ', M, N, 2, -1)
END IF
*
* Determine if the workspace size satisfies minimum size
-*
+*
LMINWS = .FALSE.
- IF((LWORK1.LT.MAX(1, NB*N*NBLCKS+5)
- $ .OR.(LWORK2.LT.NB*N)).AND.(LWORK2.GE.N).AND.(LWORK1.GT.N+5)
+ IF((LWORK1.LT.MAX(1, NB*N*NBLCKS+5)
+ $ .OR.(LWORK2.LT.NB*N)).AND.(LWORK2.GE.N).AND.(LWORK1.GT.N+5)
$ .AND.(.NOT.LQUERY)) THEN
IF (LWORK1.LT.MAX(1, NB * N * NBLCKS+5)) THEN
LMINWS = .TRUE.
NB = 1
- END IF
+ END IF
IF (LWORK1.LT.MAX(1, N * NBLCKS+5)) THEN
LMINWS = .TRUE.
- MB = M
+ MB = M
END IF
IF (LWORK2.LT.NB*N) THEN
LMINWS = .TRUE.
INFO = -2
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -4
- ELSE IF( LWORK1.LT.MAX( 1, NB * N * NBLCKS + 5 )
+ ELSE IF( LWORK1.LT.MAX( 1, NB * N * NBLCKS + 5 )
$ .AND.(.NOT.LQUERY).AND.(.NOT.LMINWS)) THEN
INFO = -6
- ELSE IF( (LWORK2.LT.MAX(1,N*NB)).AND.(.NOT.LQUERY)
+ ELSE IF( (LWORK2.LT.MAX(1,N*NB)).AND.(.NOT.LQUERY)
$ .AND.(.NOT.LMINWS)) THEN
- INFO = -8
- END IF
+ INFO = -8
+ END IF
IF( INFO.EQ.0) THEN
WORK1(1) = 1
*
IF((M.LE.N).OR.(MB.LE.N).OR.(MB.GE.M)) THEN
CALL ZGEQRT( M, N, NB, A, LDA, WORK1(6), NB, WORK2, INFO)
- ELSE
- CALL ZLATSQR( M, N, MB, NB, A, LDA, WORK1(6), NB, WORK2,
+ ELSE
+ CALL ZLATSQR( M, N, MB, NB, A, LDA, WORK1(6), NB, WORK2,
$ LWORK2, INFO)
END IF
RETURN
-*
+*
* End of ZGEQR
*
- END
\ No newline at end of file
+ END
*
* End of ZGETSLS
*
- END
\ No newline at end of file
+ END
*> indicating the nonzero elements in Z. The i-th eigenvector
*> is nonzero only in elements ISUPPZ( 2*i-1 ) through
*> ISUPPZ( 2*i ). This is an output of ZSTEMR (tridiagonal
-*> matrix). The support of the eigenvectors of A is typically
+*> matrix). The support of the eigenvectors of A is typically
*> 1:N because of the unitary transformations applied by ZUNMTR.
*> Implemented only for RANGE = 'A' or 'I' and IU - IL = N - 1
*> \endverbatim
*
* =========== DOCUMENTATION ===========
*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
-*> Download ZHESV_AASEN + dependencies
-*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zhesv_aasen.f">
-*> [TGZ]</a>
-*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zhesv_aasen.f">
-*> [ZIP]</a>
-*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zhesv_aasen.f">
+*> Download ZHESV_AASEN + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zhesv_aasen.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zhesv_aasen.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zhesv_aasen.f">
*> [TXT]</a>
-*> \endhtmlonly
+*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZHESV_AASEN( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK,
* LWORK, INFO )
-*
+*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER INFO, LDA, LDB, LWORK, N, NRHS
* INTEGER IPIV( * )
* COMPLEX*16 A( LDA, * ), B( LDB, * ), WORK( * )
* ..
-*
+*
*
*> \par Purpose:
* =============
*> A = U * T * U**H, if UPLO = 'U', or
*> A = L * T * L**H, if UPLO = 'L',
*> where U (or L) is a product of permutation and unit upper (lower)
-*> triangular matrices, and T is Hermitian and tridiagonal. The factored form
+*> triangular matrices, and T is Hermitian and tridiagonal. The factored form
*> of A is then used to solve the system of equations A * X = B.
*> \endverbatim
*
*> \param[out] IPIV
*> \verbatim
*> IPIV is INTEGER array, dimension (N)
-*> On exit, it contains the details of the interchanges, i.e.,
-*> the row and column k of A were interchanged with the
+*> On exit, it contains the details of the interchanges, i.e.,
+*> the row and column k of A were interchanged with the
*> row and column IPIV(k).
*> \endverbatim
*>
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
*> \date November 2016
*
*
* =========== DOCUMENTATION ===========
*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
-*> Download ZHETRF_AASEN + dependencies
-*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zhetrf_aasen.f">
-*> [TGZ]</a>
-*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zhetrf_aasen.f">
-*> [ZIP]</a>
-*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zhetrf_aasen.f">
+*> Download ZHETRF_AASEN + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zhetrf_aasen.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zhetrf_aasen.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zhetrf_aasen.f">
*> [TXT]</a>
-*> \endhtmlonly
+*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZHETRF_AASEN( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )
-*
+*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER N, LDA, LWORK, INFO
*> triangular part of A is not referenced.
*>
*> On exit, the tridiagonal matrix is stored in the diagonals
-*> and the subdiagonals of A just below (or above) the diagonals,
+*> and the subdiagonals of A just below (or above) the diagonals,
*> and L is stored below (or above) the subdiaonals, when UPLO
*> is 'L' (or 'U').
*> \endverbatim
*> \param[out] IPIV
*> \verbatim
*> IPIV is INTEGER array, dimension (N)
-*> On exit, it contains the details of the interchanges, i.e.,
-*> the row and column k of A were interchanged with the
+*> On exit, it contains the details of the interchanges, i.e.,
+*> the row and column k of A were interchanged with the
*> row and column IPIV(k).
*> \endverbatim
*>
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
*> \date November 2016
*
*
J = 0
10 CONTINUE
- IF( J.GE.N )
+ IF( J.GE.N )
$ GO TO 20
*
* each step of the main loop
* J is the last column of the previous panel
* J1 is the first column of the current panel
* K1 identifies if the previous column of the panel has been
-* explicitly stored, e.g., K1=1 for the first panel, and
+* explicitly stored, e.g., K1=1 for the first panel, and
* K1=0 for the rest
*
J1 = J + 1
*
* Panel factorization
*
- CALL ZLAHEF_AASEN( UPLO, 2-K1, N-J, JB,
+ CALL ZLAHEF_AASEN( UPLO, 2-K1, N-J, JB,
$ A( MAX(1, J), J+1 ), LDA,
- $ IPIV( J+1 ), WORK, N, WORK( N*NB+1 ),
+ $ IPIV( J+1 ), WORK, N, WORK( N*NB+1 ),
$ IINFO )
IF( (IINFO.GT.0) .AND. (INFO.EQ.0) ) THEN
INFO = IINFO+J
- ENDIF
+ ENDIF
*
* Ajust IPIV and apply it back (J-th step picks (J+1)-th pivot)
*
DO J2 = J+2, MIN(N, J+JB+1)
IPIV( J2 ) = IPIV( J2 ) + J
IF( (J2.NE.IPIV(J2)) .AND. ((J1-K1).GT.2) ) THEN
- CALL ZSWAP( J1-K1-2, A( 1, J2 ), 1,
+ CALL ZSWAP( J1-K1-2, A( 1, J2 ), 1,
$ A( 1, IPIV(J2) ), 1 )
END IF
END DO
J = J + JB
*
* Trailing submatrix update, where
-* the row A(J1-1, J2-1:N) stores U(J1, J2+1:N) and
+* the row A(J1-1, J2-1:N) stores U(J1, J2+1:N) and
* WORK stores the current block of the auxiriarly matrix H
*
IF( J.LT.N ) THEN
*
K2 = 0
*
-* First update skips the first column
+* First update skips the first column
*
JB = JB - 1
END IF
*
* Update off-diagonal block of J2-th block row with ZGEMM
*
- CALL ZGEMM( 'Conjugate transpose', 'Transpose',
+ CALL ZGEMM( 'Conjugate transpose', 'Transpose',
$ NJ, N-J3+1, JB+1,
$ -ONE, A( J1-K2, J2 ), LDA,
$ WORK( (J3-J1+1)+K1*N ), N,
* Factorize A as L*D*L**T using the lower triangle of A
* .....................................................
*
-* copy first column A(1:N, 1) into H(1:N, 1)
+* copy first column A(1:N, 1) into H(1:N, 1)
* (stored in WORK(1:N))
*
CALL ZCOPY( N, A( 1, 1 ), 1, WORK( 1 ), 1 )
*
J = 0
11 CONTINUE
- IF( J.GE.N )
+ IF( J.GE.N )
$ GO TO 20
*
* each step of the main loop
* J is the last column of the previous panel
* J1 is the first column of the current panel
* K1 identifies if the previous column of the panel has been
-* explicitly stored, e.g., K1=1 for the first panel, and
+* explicitly stored, e.g., K1=1 for the first panel, and
* K1=0 for the rest
*
J1 = J+1
*
* Panel factorization
*
- CALL ZLAHEF_AASEN( UPLO, 2-K1, N-J, JB,
+ CALL ZLAHEF_AASEN( UPLO, 2-K1, N-J, JB,
$ A( J+1, MAX(1, J) ), LDA,
$ IPIV( J+1 ), WORK, N, WORK( N*NB+1 ), IINFO)
IF( (IINFO.GT.0) .AND. (INFO.EQ.0) ) THEN
INFO = IINFO+J
- ENDIF
+ ENDIF
*
* Ajust IPIV and apply it back (J-th step picks (J+1)-th pivot)
*
DO J2 = J+2, MIN(N, J+JB+1)
IPIV( J2 ) = IPIV( J2 ) + J
IF( (J2.NE.IPIV(J2)) .AND. ((J1-K1).GT.2) ) THEN
- CALL ZSWAP( J1-K1-2, A( J2, 1 ), LDA,
+ CALL ZSWAP( J1-K1-2, A( J2, 1 ), LDA,
$ A( IPIV(J2), 1 ), LDA )
END IF
END DO
J = J + JB
*
* Trailing submatrix update, where
-* A(J2+1, J1-1) stores L(J2+1, J1) and
+* A(J2+1, J1-1) stores L(J2+1, J1) and
* WORK(J2+1, 1) stores H(J2+1, 1)
*
IF( J.LT.N ) THEN
*
K2 = 0
*
-* First update skips the first column
+* First update skips the first column
*
JB = JB - 1
END IF
*
* Update off-diagonal block of J2-th block column with ZGEMM
*
- CALL ZGEMM( 'No transpose', 'Conjugate transpose',
+ CALL ZGEMM( 'No transpose', 'Conjugate transpose',
$ N-J3+1, NJ, JB+1,
$ -ONE, WORK( (J3-J1+1)+K1*N ), N,
$ A( J2, J1-K2 ), LDA,
*
* =========== DOCUMENTATION ===========
*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZHETRS_AASEN + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zhetrs_aasen.f">
-*> [TGZ]</a>
+*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zhetrs_aasen.f">
-*> [ZIP]</a>
+*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zhetrs_aasen.f">
*> [TXT]</a>
-*> \endhtmlonly
+*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZHETRS_AASEN( UPLO, N, NRHS, A, LDA, IPIV, B, LDB,
* WORK, LWORK, INFO )
-*
+*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER N, NRHS, LDA, LDB, LWORK, INFO
* INTEGER IPIV( * )
* COMPLEX*16 A( LDA, * ), B( LDB, * ), WORK( * )
* ..
-*
+*
*
*> \par Purpose:
* =============
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
*> \date November 2016
*
$ B( 2, 1 ), LDB)
*
* Compute T \ B -> B [ T \ (U \P**T * B) ]
-*
+*
CALL ZLACPY( 'F', 1, N, A(1, 1), LDA+1, WORK(N), 1)
IF( N.GT.1 ) THEN
CALL ZLACPY( 'F', 1, N-1, A( 1, 2 ), LDA+1, WORK( 2*N ), 1)
END IF
CALL ZGTSV(N, NRHS, WORK(1), WORK(N), WORK(2*N), B, LDB,
$ INFO)
-*
+*
* Compute (U**T \ B) -> B [ U**T \ (T \ (U \P**T * B) ) ]
*
CALL ZTRSM( 'L', 'U', 'N', 'U', N-1, NRHS, ONE, A( 1, 2 ), LDA,
END IF
CALL ZGTSV(N, NRHS, WORK(1), WORK(N), WORK(2*N), B, LDB,
$ INFO)
-*
+*
* Compute (L**T \ B) -> B [ L**T \ (T \ (L \P**T * B) ) ]
-*
+*
CALL ZTRSM( 'L', 'L', 'C', 'U', N-1, NRHS, ONE, A( 2, 1 ), LDA,
$ B( 2, 1 ), LDB)
*
*
* =========== DOCUMENTATION ===========
*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
-*> Download ZLAHEF_AASEN + dependencies
-*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlahef_aasen.f">
-*> [TGZ]</a>
-*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlahef_aasen.f">
-*> [ZIP]</a>
-*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlahef_aasen.f">
+*> Download ZLAHEF_AASEN + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlahef_aasen.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlahef_aasen.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlahef_aasen.f">
*> [TXT]</a>
-*> \endhtmlonly
+*> \endhtmlonly
*
* Definition:
* ===========
*
-* SUBROUTINE ZLAHEF_AASEN( UPLO, J1, M, NB, A, LDA, IPIV,
+* SUBROUTINE ZLAHEF_AASEN( UPLO, J1, M, NB, A, LDA, IPIV,
* H, LDH, WORK, INFO )
-*
+*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER J1, M, NB, LDA, LDH, INFO
* INTEGER IPIV( * )
* COMPLEX*16 A( LDA, * ), H( LDH, * ), WORK( * )
* ..
-*
+*
*
*> \par Purpose:
* =============
*> last row, or column, of the previous panel. The first row, or column,
*> of A is set to be the first row, or column, of an identity matrix,
*> which is used to factorize the first panel.
-*>
+*>
*> The resulting J-th row of U, or J-th column of L, is stored in the
-*> (J-1)-th row, or column, of A (without the unit diatonals), while
+*> (J-1)-th row, or column, of A (without the unit diatonals), while
*> the diagonal and subdiagonal of A are overwritten by those of T.
*>
*> \endverbatim
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
*> \date November 2016
*
* @precisions fortran z -> c
*
* =====================================================================
- SUBROUTINE ZLAHEF_AASEN( UPLO, J1, M, NB, A, LDA, IPIV,
+ SUBROUTINE ZLAHEF_AASEN( UPLO, J1, M, NB, A, LDA, IPIV,
$ H, LDH, WORK, INFO )
*
* -- LAPACK computational routine (version 3.4.0) --
*
* .. Local Scalars ..
INTEGER J, K, K1, I1, I2
- COMPLEX*16 PIV, ALPHA
+ COMPLEX*16 PIV, ALPHA
* ..
* .. External Functions ..
LOGICAL LSAME
*
A( K, J ) = DBLE( WORK( 1 ) )
*
- IF( J.LT.M ) THEN
+ IF( J.LT.M ) THEN
*
* Compute WORK(2:N) = T(J, J) L(J, (J+1):N)
* where A(J, J) stores T(J, J) and A(J-1, (J+1):N) stores U(J, (J+1):N)
*
IF( (J1+J-1).GT.1 ) THEN
- ALPHA = -A( K, J )
- CALL ZAXPY( M-J, ALPHA, A( K-1, J+1 ), LDA,
+ ALPHA = -A( K, J )
+ CALL ZAXPY( M-J, ALPHA, A( K-1, J+1 ), LDA,
$ WORK( 2 ), 1 )
ENDIF
*
*
I1 = I1+J-1
I2 = I2+J-1
- CALL ZSWAP( I2-I1-1, A( J1+I1-1, I1+1 ), LDA,
+ CALL ZSWAP( I2-I1-1, A( J1+I1-1, I1+1 ), LDA,
$ A( J1+I1, I2 ), 1 )
CALL ZLACGV( I2-I1, A( J1+I1-1, I1+1 ), LDA )
CALL ZLACGV( I2-I1-1, A( J1+I1, I2 ), 1 )
*
* Swap A(I1, I2+1:N) with A(I2, I2+1:N)
*
- CALL ZSWAP( M-I2, A( J1+I1-1, I2+1 ), LDA,
+ CALL ZSWAP( M-I2, A( J1+I1-1, I2+1 ), LDA,
$ A( J1+I2-1, I2+1 ), LDA )
*
* Swap A(I1, I1) with A(I2,I2)
* Swap L(1:I1-1, I1) with L(1:I1-1, I2),
* skipping the first column
*
- CALL ZSWAP( I1-K1+1, A( 1, I1 ), 1,
+ CALL ZSWAP( I1-K1+1, A( 1, I1 ), 1,
$ A( 1, I2 ), 1 )
END IF
- ELSE
+ ELSE
IPIV( J+1 ) = J+1
ENDIF
*
* Set A(J, J+1) = T(J, J+1)
*
A( K, J+1 ) = WORK( 2 )
- IF( (A( K, J ).EQ.ZERO ) .AND.
+ IF( (A( K, J ).EQ.ZERO ) .AND.
$ ( (J.EQ.M) .OR. (A( K, J+1 ).EQ.ZERO))) THEN
IF(INFO .EQ. 0) THEN
INFO = J
*
IF( J.LT.NB ) THEN
*
-* Copy A(J+1:N, J+1) into H(J:N, J),
+* Copy A(J+1:N, J+1) into H(J:N, J),
*
- CALL ZCOPY( M-J, A( K+1, J+1 ), LDA,
+ CALL ZCOPY( M-J, A( K+1, J+1 ), LDA,
$ H( J+1, J+1 ), 1 )
END IF
*
CALL ZCOPY( M-J-1, WORK( 3 ), 1, A( K, J+2 ), LDA )
CALL ZSCAL( M-J-1, ALPHA, A( K, J+2 ), LDA )
ELSE
- CALL ZLASET( 'Full', 1, M-J-1, ZERO, ZERO,
+ CALL ZLASET( 'Full', 1, M-J-1, ZERO, ZERO,
$ A( K, J+2 ), LDA)
END IF
ELSE
*
A( J, K ) = DBLE( WORK( 1 ) )
*
- IF( J.LT.M ) THEN
+ IF( J.LT.M ) THEN
*
* Compute WORK(2:N) = T(J, J) L((J+1):N, J)
* where A(J, J) = T(J, J) and A((J+1):N, J-1) = L((J+1):N, J)
*
IF( (J1+J-1).GT.1 ) THEN
ALPHA = -A( J, K )
- CALL ZAXPY( M-J, ALPHA, A( J+1, K-1 ), 1,
+ CALL ZAXPY( M-J, ALPHA, A( J+1, K-1 ), 1,
$ WORK( 2 ), 1 )
ENDIF
*
*
I1 = I1+J-1
I2 = I2+J-1
- CALL ZSWAP( I2-I1-1, A( I1+1, J1+I1-1 ), 1,
+ CALL ZSWAP( I2-I1-1, A( I1+1, J1+I1-1 ), 1,
$ A( I2, J1+I1 ), LDA )
CALL ZLACGV( I2-I1, A( I1+1, J1+I1-1 ), 1 )
CALL ZLACGV( I2-I1-1, A( I2, J1+I1 ), LDA )
*
* Swap A(I2+1:N, I1) with A(I2+1:N, I2)
*
- CALL ZSWAP( M-I2, A( I2+1, J1+I1-1 ), 1,
+ CALL ZSWAP( M-I2, A( I2+1, J1+I1-1 ), 1,
$ A( I2+1, J1+I2-1 ), 1 )
*
* Swap A(I1, I1) with A(I2, I2)
* Swap L(1:I1-1, I1) with L(1:I1-1, I2),
* skipping the first column
*
- CALL ZSWAP( I1-K1+1, A( I1, 1 ), LDA,
+ CALL ZSWAP( I1-K1+1, A( I1, 1 ), LDA,
$ A( I2, 1 ), LDA )
END IF
- ELSE
+ ELSE
IPIV( J+1 ) = J+1
ENDIF
*
* Set A(J+1, J) = T(J+1, J)
*
A( J+1, K ) = WORK( 2 )
- IF( (A( J, K ).EQ.ZERO) .AND.
+ IF( (A( J, K ).EQ.ZERO) .AND.
$ ( (J.EQ.M) .OR. (A( J+1, K ).EQ.ZERO)) ) THEN
- IF (INFO .EQ. 0)
+ IF (INFO .EQ. 0)
$ INFO = J
END IF
*
IF( J.LT.NB ) THEN
*
-* Copy A(J+1:N, J+1) into H(J+1:N, J),
+* Copy A(J+1:N, J+1) into H(J+1:N, J),
*
- CALL ZCOPY( M-J, A( J+1, K+1 ), 1,
+ CALL ZCOPY( M-J, A( J+1, K+1 ), 1,
$ H( J+1, J+1 ), 1 )
END IF
*
CALL ZCOPY( M-J-1, WORK( 3 ), 1, A( J+2, K ), 1 )
CALL ZSCAL( M-J-1, ALPHA, A( J+2, K ), 1 )
ELSE
- CALL ZLASET( 'Full', M-J-1, 1, ZERO, ZERO,
+ CALL ZLASET( 'Full', M-J-1, 1, ZERO, ZERO,
$ A( J+2, K ), LDA )
END IF
ELSE
- IF( (A( J, K ).EQ.ZERO) .AND. (J.EQ.M)
+ IF( (A( J, K ).EQ.ZERO) .AND. (J.EQ.M)
$ .AND. (INFO.EQ.0) ) INFO = J
END IF
J = J + 1
-*
+*
* Definition:
* ===========
*
-* SUBROUTINE ZLAMSWLQ( SIDE, TRANS, M, N, K, MB, NB, A, LDA, T,
+* SUBROUTINE ZLAMSWLQ( SIDE, TRANS, M, N, K, MB, NB, A, LDA, T,
* $ LDT, C, LDC, WORK, LWORK, INFO )
*
*
* =============
*>
*> \verbatim
-*>
+*>
*> ZLAMQRTS overwrites the general real M-by-N matrix C with
*>
-*>
+*>
*> SIDE = 'L' SIDE = 'R'
*> TRANS = 'N': Q * C C * Q
*> TRANS = 'T': Q**T * C C * Q**T
*> where Q is a real orthogonal matrix defined as the product of blocked
-*> elementary reflectors computed by short wide LQ
+*> elementary reflectors computed by short wide LQ
*> factorization (ZLASWLQ)
*> \endverbatim
*
*> The number of elementary reflectors whose product defines
*> the matrix Q.
*> M >= K >= 0;
-*>
+*>
*> \endverbatim
*> \param[in] MB
*> \verbatim
*> MB is INTEGER
-*> The row block size to be used in the blocked QR.
-*> M >= MB >= 1
+*> The row block size to be used in the blocked QR.
+*> M >= MB >= 1
*> \endverbatim
*>
*> \param[in] NB
*> \verbatim
*> NB is INTEGER
-*> The column block size to be used in the blocked QR.
+*> The column block size to be used in the blocked QR.
*> NB > M.
*> \endverbatim
*>
*> \param[in] NB
*> \verbatim
*> NB is INTEGER
-*> The block size to be used in the blocked QR.
+*> The block size to be used in the blocked QR.
*> MB > M.
-*>
+*>
*> \endverbatim
*>
*> \param[in,out] A
*>
*> \param[in] T
*> \verbatim
-*> T is COMPLEX*16 array, dimension
+*> T is COMPLEX*16 array, dimension
*> ( M * Number of blocks(CEIL(N-K/NB-K)),
*> The blocked upper triangular block reflectors stored in compact form
*> as a sequence of upper triangular blocks. See below
*> \param[out] WORK
*> \verbatim
*> (workspace) COMPLEX*16 array, dimension (MAX(1,LWORK))
-*>
+*>
*> \endverbatim
*> \param[in] LWORK
*> \verbatim
*> block reflectors, stored in array T(1:LDT,(i-1)*M+1:i*M).
*> The last Q(k) may use fewer rows.
*> For more information see Further Details in TPQRT.
-*>
+*>
*> For more details of the overall algorithm, see the description of
*> Sequential TSQR in Section 2.2 of [1].
*>
*> \endverbatim
*>
* =====================================================================
- SUBROUTINE ZLAMSWLQ( SIDE, TRANS, M, N, K, MB, NB, A, LDA, T,
+ SUBROUTINE ZLAMSWLQ( SIDE, TRANS, M, N, K, MB, NB, A, LDA, T,
$ LDT, C, LDC, WORK, LWORK, INFO )
*
* -- LAPACK computational routine (version 3.5.0) --
*
IF( MIN(M,N,K).EQ.0 ) THEN
RETURN
- END IF
+ END IF
*
IF((NB.LE.K).OR.(NB.GE.MAX(M,N,K))) THEN
- CALL ZGEMLQT( SIDE, TRANS, M, N, K, MB, A, LDA,
- $ T, LDT, C, LDC, WORK, INFO)
+ CALL ZGEMLQT( SIDE, TRANS, M, N, K, MB, A, LDA,
+ $ T, LDT, C, LDC, WORK, INFO)
RETURN
END IF
*
IF(II.LE.N) THEN
*
* Multiply Q to the last block of C
-*
+*
CALL ZTPMLQT('R','C',M , KK, K, 0,MB, A(1,II), LDA,
$ T(1, CTR * K + 1),LDT, C(1,1), LDC,
$ C(1,II), LDC, WORK, INFO )
*
* End of ZLAMSWLQ
*
- END
\ No newline at end of file
+ END
-*
+*
* Definition:
* ===========
*
-* SUBROUTINE ZLAMTSQR( SIDE, TRANS, M, N, K, MB, NB, A, LDA, T,
+* SUBROUTINE ZLAMTSQR( SIDE, TRANS, M, N, K, MB, NB, A, LDA, T,
* $ LDT, C, LDC, WORK, LWORK, INFO )
*
*
* =============
*>
*> \verbatim
-*>
+*>
*> ZLAMTSQR overwrites the general complex M-by-N matrix C with
*>
-*>
+*>
*> SIDE = 'L' SIDE = 'R'
*> TRANS = 'N': Q * C C * Q
*> TRANS = 'C': Q**C * C C * Q**C
-*> where Q is a real orthogonal matrix defined as the product
-*> of blocked elementary reflectors computed by tall skinny
+*> where Q is a real orthogonal matrix defined as the product
+*> of blocked elementary reflectors computed by tall skinny
*> QR factorization (ZLATSQR)
*> \endverbatim
*
*> The number of elementary reflectors whose product defines
*> the matrix Q.
*> N >= K >= 0;
-*>
+*>
*> \endverbatim
*>
*> \param[in] MB
*> \verbatim
*> MB is INTEGER
-*> The block size to be used in the blocked QR.
+*> The block size to be used in the blocked QR.
*> MB > N. (must be the same as DLATSQR)
*> \endverbatim
*>
*> \param[in] NB
*> \verbatim
*> NB is INTEGER
-*> The column block size to be used in the blocked QR.
+*> The column block size to be used in the blocked QR.
*> N >= NB >= 1.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,K)
-*> The i-th column must contain the vector which defines the
-*> blockedelementary reflector H(i), for i = 1,2,...,k, as
-*> returned by DLATSQR in the first k columns of
+*> The i-th column must contain the vector which defines the
+*> blockedelementary reflector H(i), for i = 1,2,...,k, as
+*> returned by DLATSQR in the first k columns of
*> its array argument A.
*> \endverbatim
*>
*>
*> \param[in] T
*> \verbatim
-*> T is COMPLEX*16 array, dimension
+*> T is COMPLEX*16 array, dimension
*> ( N * Number of blocks(CEIL(M-K/MB-K)),
*> The blocked upper triangular block reflectors stored in compact form
*> as a sequence of upper triangular blocks. See below
*> \param[out] WORK
*> \verbatim
*> (workspace) COMPLEX*16 array, dimension (MAX(1,LWORK))
-*>
+*>
*> \endverbatim
*> \param[in] LWORK
*> \verbatim
*> LWORK is INTEGER
*> The dimension of the array WORK.
-*>
+*>
*> If SIDE = 'L', LWORK >= max(1,N)*NB;
*> if SIDE = 'R', LWORK >= max(1,MB)*NB.
*> If LWORK = -1, then a workspace query is assumed; the routine
*> block reflectors, stored in array T(1:LDT,(i-1)*N+1:i*N).
*> The last Q(k) may use fewer rows.
*> For more information see Further Details in TPQRT.
-*>
+*>
*> For more details of the overall algorithm, see the description of
*> Sequential TSQR in Section 2.2 of [1].
*>
*> \endverbatim
*>
* =====================================================================
- SUBROUTINE ZLAMTSQR( SIDE, TRANS, M, N, K, MB, NB, A, LDA, T,
+ SUBROUTINE ZLAMTSQR( SIDE, TRANS, M, N, K, MB, NB, A, LDA, T,
$ LDT, C, LDC, WORK, LWORK, INFO )
*
* -- LAPACK computational routine (version 3.5.0) --
LOGICAL LSAME
EXTERNAL LSAME
* .. External Subroutines ..
- EXTERNAL ZGEMQRT, ZTPMQRT, XERBLA
+ EXTERNAL ZGEMQRT, ZTPMQRT, XERBLA
* ..
* .. Executable Statements ..
*
END IF
*
* Determine the block size if it is tall skinny or short and wide
-*
+*
IF( INFO.EQ.0) THEN
WORK(1) = LW
END IF
-*
+*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZLAMTSQR', -INFO )
RETURN
END IF
*
IF((MB.LE.K).OR.(MB.GE.MAX(M,N,K))) THEN
- CALL ZGEMQRT( SIDE, TRANS, M, N, K, NB, A, LDA,
- $ T, LDT, C, LDC, WORK, INFO)
+ CALL ZGEMQRT( SIDE, TRANS, M, N, K, NB, A, LDA,
+ $ T, LDT, C, LDC, WORK, INFO)
RETURN
- END IF
+ END IF
*
IF(LEFT.AND.NOTRAN) THEN
*
IF(II.LE.M) THEN
*
* Multiply Q to the last block of C
-*
+*
CALL ZTPMQRT('L','C',KK , N, K, 0,NB, A(II,1), LDA,
$ T(1, CTR * K + 1), LDT, C(1,1), LDC,
$ C(II,1), LDC, WORK, INFO )
*
END IF
*
- WORK(1) = LW
+ WORK(1) = LW
RETURN
*
* End of ZLAMTSQR
*
- END
\ No newline at end of file
+ END
-*
+*
* Definition:
* ===========
*
* SUBROUTINE ZLASWLQ( M, N, MB, NB, A, LDA, T, LDT, WORK,
* LWORK, INFO)
-*
+*
* .. Scalar Arguments ..
* INTEGER INFO, LDA, M, N, MB, NB, LDT, LWORK
* ..
* .. Array Arguments ..
* COMPLEX*16 A( LDA, * ), T( LDT, * ), WORK( * )
* ..
-*
+*
*
*> \par Purpose:
* =============
*>
*> \verbatim
-*>
-*> ZLASWLQ computes a blocked Short-Wide LQ factorization of a
+*>
+*> ZLASWLQ computes a blocked Short-Wide LQ factorization of a
*> M-by-N matrix A, where N >= M:
*> A = L * Q
*> \endverbatim
*> \param[in] MB
*> \verbatim
*> MB is INTEGER
-*> The row block size to be used in the blocked QR.
-*> M >= MB >= 1
+*> The row block size to be used in the blocked QR.
+*> M >= MB >= 1
*> \endverbatim
*> \param[in] NB
*> \verbatim
*> NB is INTEGER
-*> The column block size to be used in the blocked QR.
+*> The column block size to be used in the blocked QR.
*> NB > M.
*> \endverbatim
*>
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> On entry, the M-by-N matrix A.
-*> On exit, the elements on and bleow the diagonal
-*> of the array contain the N-by-N lower triangular matrix L;
-*> the elements above the diagonal represent Q by the rows
+*> On exit, the elements on and bleow the diagonal
+*> of the array contain the N-by-N lower triangular matrix L;
+*> the elements above the diagonal represent Q by the rows
*> of blocked V (see Further Details).
*>
*> \endverbatim
*>
*> \param[out] T
*> \verbatim
-*> T is COMPLEX*16 array,
-*> dimension (LDT, N * Number_of_row_blocks)
+*> T is COMPLEX*16 array,
+*> dimension (LDT, N * Number_of_row_blocks)
*> where Number_of_row_blocks = CEIL((N-M)/(NB-M))
*> The blocked upper triangular block reflectors stored in compact form
-*> as a sequence of upper triangular blocks.
+*> as a sequence of upper triangular blocks.
*> See Further Details below.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> (workspace) COMPLEX*16 array, dimension (MAX(1,LWORK))
-*>
+*>
*> \endverbatim
*> \param[in] LWORK
*> \verbatim
*> block reflectors, stored in array T(1:LDT,(i-1)*M+1:i*M).
*> The last Q(k) may use fewer rows.
*> For more information see Further Details in TPQRT.
-*>
+*>
*> For more details of the overall algorithm, see the description of
*> Sequential TSQR in Section 2.2 of [1].
*>
*> \endverbatim
*>
* =====================================================================
- SUBROUTINE ZLASWLQ( M, N, MB, NB, A, LDA, T, LDT, WORK, LWORK,
+ SUBROUTINE ZLASWLQ( M, N, MB, NB, A, LDA, T, LDT, WORK, LWORK,
$ INFO)
*
* -- LAPACK computational routine (version 3.5.0) --
ELSE IF( N.LT.0 .OR. N.LT.M ) THEN
INFO = -2
ELSE IF( MB.LT.1 .OR. ( MB.GT.M .AND. M.GT.0 )) THEN
- INFO = -3
+ INFO = -3
ELSE IF( NB.LE.M ) THEN
INFO = -4
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
ELSE IF( LDT.LT.MB ) THEN
INFO = -8
ELSE IF( ( LWORK.LT.M*MB) .AND. (.NOT.LQUERY) ) THEN
- INFO = -10
- END IF
- IF( INFO.EQ.0) THEN
+ INFO = -10
+ END IF
+ IF( INFO.EQ.0) THEN
WORK(1) = MB*M
END IF
*
IF((M.GE.N).OR.(NB.LE.M).OR.(NB.GE.N)) THEN
CALL ZGELQT( M, N, MB, A, LDA, T, LDT, WORK, INFO)
RETURN
- END IF
-*
+ END IF
+*
KK = MOD((N-M),(NB-M))
- II=N-KK+1
+ II=N-KK+1
*
* Compute the LQ factorization of the first block A(1:M,1:NB)
*
CTR = 1
*
DO I = NB+1, II-NB+M , (NB-M)
-*
+*
* Compute the QR factorization of the current block A(1:M,I:I+NB-M)
*
CALL ZTPLQT( M, NB-M, 0, MB, A(1,1), LDA, A( 1, I ),
CALL ZTPLQT( M, KK, 0, MB, A(1,1), LDA, A( 1, II ),
$ LDA, T(1, CTR * M + 1), LDT,
$ WORK, INFO )
- END IF
+ END IF
*
WORK( 1 ) = M * MB
RETURN
-*
+*
* End of ZLASWLQ
*
- END
\ No newline at end of file
+ END
-*
+*
* Definition:
* ===========
*
-* SUBROUTINE ZLATSQR( M, N, MB, NB, A, LDA, T, LDT, WORK,
+* SUBROUTINE ZLATSQR( M, N, MB, NB, A, LDA, T, LDT, WORK,
* LWORK, INFO)
-*
+*
* .. Scalar Arguments ..
* INTEGER INFO, LDA, M, N, MB, NB, LDT, LWORK
* ..
* .. Array Arguments ..
* COMPLEX*16 A( LDA, * ), T( LDT, * ), WORK( * )
* ..
-*
+*
*
*> \par Purpose:
* =============
*>
*> \verbatim
-*>
-*> SLATSQR computes a blocked Tall-Skinny QR factorization of
+*>
+*> SLATSQR computes a blocked Tall-Skinny QR factorization of
*> an M-by-N matrix A, where M >= N:
-*> A = Q * R .
+*> A = Q * R .
*> \endverbatim
*
* Arguments:
*> \param[in] MB
*> \verbatim
*> MB is INTEGER
-*> The row block size to be used in the blocked QR.
+*> The row block size to be used in the blocked QR.
*> MB > N.
*> \endverbatim
*>
*> \param[in] NB
*> \verbatim
*> NB is INTEGER
-*> The column block size to be used in the blocked QR.
+*> The column block size to be used in the blocked QR.
*> N >= NB >= 1.
*> \endverbatim
*>
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> On entry, the M-by-N matrix A.
-*> On exit, the elements on and above the diagonal
-*> of the array contain the N-by-N upper triangular matrix R;
-*> the elements below the diagonal represent Q by the columns
+*> On exit, the elements on and above the diagonal
+*> of the array contain the N-by-N upper triangular matrix R;
+*> the elements below the diagonal represent Q by the columns
*> of blocked V (see Further Details).
*> \endverbatim
*>
*>
*> \param[out] T
*> \verbatim
-*> T is COMPLEX*16 array,
-*> dimension (LDT, N * Number_of_row_blocks)
+*> T is COMPLEX*16 array,
+*> dimension (LDT, N * Number_of_row_blocks)
*> where Number_of_row_blocks = CEIL((M-N)/(MB-N))
*> The blocked upper triangular block reflectors stored in compact form
-*> as a sequence of upper triangular blocks.
+*> as a sequence of upper triangular blocks.
*> See Further Details below.
*> \endverbatim
*>
*>
*> \param[out] WORK
*> \verbatim
-*> (workspace) COMPLEX*16 array, dimension (MAX(1,LWORK))
+*> (workspace) COMPLEX*16 array, dimension (MAX(1,LWORK))
*> \endverbatim
*>
*> \param[in] LWORK
*> block reflectors, stored in array T(1:LDT,(i-1)*N+1:i*N).
*> The last Q(k) may use fewer rows.
*> For more information see Further Details in TPQRT.
-*>
+*>
*> For more details of the overall algorithm, see the description of
*> Sequential TSQR in Section 2.2 of [1].
*>
*> \endverbatim
*>
* =====================================================================
- SUBROUTINE ZLATSQR( M, N, MB, NB, A, LDA, T, LDT, WORK,
+ SUBROUTINE ZLATSQR( M, N, MB, NB, A, LDA, T, LDT, WORK,
$ LWORK, INFO)
*
* -- LAPACK computational routine (version 3.5.0) --
ELSE IF( N.LT.0 .OR. M.LT.N ) THEN
INFO = -2
ELSE IF( MB.LE.N ) THEN
- INFO = -3
+ INFO = -3
ELSE IF( NB.LT.1 .OR. ( NB.GT.N .AND. N.GT.0 )) THEN
INFO = -4
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
ELSE IF( LDT.LT.NB ) THEN
INFO = -8
ELSE IF( LWORK.LT.(N*NB) .AND. (.NOT.LQUERY) ) THEN
- INFO = -10
- END IF
+ INFO = -10
+ END IF
IF( INFO.EQ.0) THEN
WORK(1) = NB*N
END IF
IF ((MB.LE.N).OR.(MB.GE.M)) THEN
CALL ZGEQRT( M, N, NB, A, LDA, T, LDT, WORK, INFO)
RETURN
- END IF
+ END IF
KK = MOD((M-N),(MB-N))
- II=M-KK+1
+ II=M-KK+1
*
* Compute the QR factorization of the first block A(1:MB,1:N)
*
CTR = 1
*
DO I = MB+1, II-MB+N , (MB-N)
-*
+*
* Compute the QR factorization of the current block A(I:I+MB-N,1:N)
*
CALL ZTPQRT( MB-N, N, 0, NB, A(1,1), LDA, A( I, 1 ), LDA,
CALL ZTPQRT( KK, N, 0, NB, A(1,1), LDA, A( II, 1 ), LDA,
$ T(1,CTR * N + 1), LDT,
$ WORK, INFO )
- END IF
+ END IF
*
work( 1 ) = N*NB
RETURN
-*
+*
* End of ZLATSQR
*
- END
\ No newline at end of file
+ END
*
* =========== DOCUMENTATION ===========
*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
-*> Download DTPQRT + dependencies
-*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dtplqt.f">
-*> [TGZ]</a>
-*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dtplqt.f">
-*> [ZIP]</a>
-*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dtplqt.f">
+*> Download DTPQRT + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dtplqt.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dtplqt.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dtplqt.f">
*> [TXT]</a>
-*> \endhtmlonly
+*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZTPLQT( M, N, L, MB, A, LDA, B, LDB, T, LDT, WORK,
* INFO )
-*
+*
* .. Scalar Arguments ..
* INTEGER INFO, LDA, LDB, LDT, N, M, L, MB
* ..
* .. Array Arguments ..
* COMPLEX*16 A( LDA, * ), B( LDB, * ), T( LDT, * ), WORK( * )
* ..
-*
+*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
-*> DTPLQT computes a blocked LQ factorization of a complex
-*> "triangular-pentagonal" matrix C, which is composed of a
-*> triangular block A and pentagonal block B, using the compact
+*> DTPLQT computes a blocked LQ factorization of a complex
+*> "triangular-pentagonal" matrix C, which is composed of a
+*> triangular block A and pentagonal block B, using the compact
*> WY representation for Q.
*> \endverbatim
*
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix B, and the order of the
-*> triangular matrix A.
+*> triangular matrix A.
*> M >= 0.
*> \endverbatim
*>
*> \param[in,out] B
*> \verbatim
*> B is COMPLEX*16 array, dimension (LDB,N)
-*> On entry, the pentagonal M-by-N matrix B. The first N-L columns
+*> On entry, the pentagonal M-by-N matrix B. The first N-L columns
*> are rectangular, and the last L columns are lower trapezoidal.
*> On exit, B contains the pentagonal matrix V. See Further Details.
*> \endverbatim
*> The lower triangular block reflectors stored in compact form
*> as a sequence of upper triangular blocks. See Further Details.
*> \endverbatim
-*>
+*>
*> \param[in] LDT
*> \verbatim
*> LDT is INTEGER
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
*> \date November 2013
*
*>
*> \verbatim
*>
-*> The input matrix C is a M-by-(M+N) matrix
+*> The input matrix C is a M-by-(M+N) matrix
*>
*> C = [ A ] [ B ]
-*>
+*>
*>
*> where A is an lower triangular N-by-N matrix, and B is M-by-N pentagonal
*> matrix consisting of a M-by-(N-L) rectangular matrix B1 on left of a M-by-L
*> upper trapezoidal matrix B2:
-*> [ B ] = [ B1 ] [ B2 ]
+*> [ B ] = [ B1 ] [ B2 ]
*> [ B1 ] <- M-by-(N-L) rectangular
*> [ B2 ] <- M-by-L upper trapezoidal.
*>
*> The lower trapezoidal matrix B2 consists of the first L columns of a
-*> N-by-N lower triangular matrix, where 0 <= L <= MIN(M,N). If L=0,
-*> B is rectangular M-by-N; if M=L=N, B is lower triangular.
+*> N-by-N lower triangular matrix, where 0 <= L <= MIN(M,N). If L=0,
+*> B is rectangular M-by-N; if M=L=N, B is lower triangular.
*>
*> The matrix W stores the elementary reflectors H(i) in the i-th row
*> above the diagonal (of A) in the M-by-(M+N) input matrix C
-*> [ C ] = [ A ] [ B ]
+*> [ C ] = [ A ] [ B ]
*> [ A ] <- lower triangular N-by-N
*> [ B ] <- M-by-N pentagonal
*>
*> so that W can be represented as
-*> [ W ] = [ I ] [ V ]
+*> [ W ] = [ I ] [ V ]
*> [ I ] <- identity, N-by-N
*> [ V ] <- M-by-N, same form as B.
*>
*> Thus, all of information needed for W is contained on exit in B, which
-*> we call V above. Note that V has the same form as B; that is,
-*> [ V ] = [ V1 ] [ V2 ]
+*> we call V above. Note that V has the same form as B; that is,
+*> [ V ] = [ V1 ] [ V2 ]
*> [ V1 ] <- M-by-(N-L) rectangular
*> [ V2 ] <- M-by-L lower trapezoidal.
*>
-*> The rows of V represent the vectors which define the H(i)'s.
+*> The rows of V represent the vectors which define the H(i)'s.
*>
*> The number of blocks is B = ceiling(M/MB), where each
-*> block is of order MB except for the last block, which is of order
+*> block is of order MB except for the last block, which is of order
*> IB = M - (M-1)*MB. For each of the B blocks, a upper triangular block
-*> reflector factor is computed: T1, T2, ..., TB. The MB-by-MB (and IB-by-IB
+*> reflector factor is computed: T1, T2, ..., TB. The MB-by-MB (and IB-by-IB
*> for the last block) T's are stored in the MB-by-N matrix T as
*>
*> T = [T1 T2 ... TB].
IF( M.EQ.0 .OR. N.EQ.0 ) RETURN
*
DO I = 1, M, MB
-*
+*
* Compute the QR factorization of the current block
*
IB = MIN( M-I+1, MB )
LB = NB-N+L-I+1
END IF
*
- CALL ZTPLQT2( IB, NB, LB, A(I,I), LDA, B( I, 1 ), LDB,
+ CALL ZTPLQT2( IB, NB, LB, A(I,I), LDA, B( I, 1 ), LDB,
$ T(1, I ), LDT, IINFO )
*
* Update by applying H**T to B(I+IB:M,:) from the right
*
IF( I+IB.LE.M ) THEN
CALL ZTPRFB( 'R', 'N', 'F', 'R', M-I-IB+1, NB, IB, LB,
- $ B( I, 1 ), LDB, T( 1, I ), LDT,
- $ A( I+IB, I ), LDA, B( I+IB, 1 ), LDB,
+ $ B( I, 1 ), LDB, T( 1, I ), LDT,
+ $ A( I+IB, I ), LDA, B( I+IB, 1 ), LDB,
$ WORK, M-I-IB+1)
END IF
END DO
RETURN
-*
+*
* End of ZTPLQT
*
END
*
* =========== DOCUMENTATION ===========
*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
-*> Download ZTPLQT2 + dependencies
-*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ztplqt2.f">
-*> [TGZ]</a>
-*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ztplqt2.f">
-*> [ZIP]</a>
-*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ztplqt2.f">
+*> Download ZTPLQT2 + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ztplqt2.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ztplqt2.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ztplqt2.f">
*> [TXT]</a>
-*> \endhtmlonly
+*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZTPLQT2( M, N, L, A, LDA, B, LDB, T, LDT, INFO )
-*
+*
* .. Scalar Arguments ..
* INTEGER INFO, LDA, LDB, LDT, N, M, L
* ..
* .. Array Arguments ..
* COMPLEX*16 A( LDA, * ), B( LDB, * ), T( LDT, * )
* ..
-*
+*
*
*> \par Purpose:
* =============
*> \verbatim
*>
*> ZTPLQT2 computes a LQ a factorization of a complex "triangular-pentagonal"
-*> matrix C, which is composed of a triangular block A and pentagonal block B,
+*> matrix C, which is composed of a triangular block A and pentagonal block B,
*> using the compact WY representation for Q.
*> \endverbatim
*
*> \param[in] M
*> \verbatim
*> M is INTEGER
-*> The total number of rows of the matrix B.
+*> The total number of rows of the matrix B.
*> M >= 0.
*> \endverbatim
*>
*> \param[in] L
*> \verbatim
*> L is INTEGER
-*> The number of rows of the lower trapezoidal part of B.
+*> The number of rows of the lower trapezoidal part of B.
*> MIN(M,N) >= L >= 0. See Further Details.
*> \endverbatim
*>
*> \param[in,out] B
*> \verbatim
*> B is COMPLEX*16 array, dimension (LDB,N)
-*> On entry, the pentagonal M-by-N matrix B. The first N-L columns
+*> On entry, the pentagonal M-by-N matrix B. The first N-L columns
*> are rectangular, and the last L columns are lower trapezoidal.
*> On exit, B contains the pentagonal matrix V. See Further Details.
*> \endverbatim
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
*> \date September 2012
*
*>
*> \verbatim
*>
-*> The input matrix C is a M-by-(M+N) matrix
+*> The input matrix C is a M-by-(M+N) matrix
*>
*> C = [ A ][ B ]
-*>
+*>
*>
*> where A is an lower triangular N-by-N matrix, and B is M-by-N pentagonal
*> matrix consisting of a M-by-(N-L) rectangular matrix B1 left of a M-by-L
*> [ B2 ] <- M-by-L lower trapezoidal.
*>
*> The lower trapezoidal matrix B2 consists of the first L columns of a
-*> N-by-N lower triangular matrix, where 0 <= L <= MIN(M,N). If L=0,
-*> B is rectangular M-by-N; if M=L=N, B is lower triangular.
+*> N-by-N lower triangular matrix, where 0 <= L <= MIN(M,N). If L=0,
+*> B is rectangular M-by-N; if M=L=N, B is lower triangular.
*>
*> The matrix W stores the elementary reflectors H(i) in the i-th row
*> above the diagonal (of A) in the M-by-(M+N) input matrix C
*>
*> so that W can be represented as
*>
-*> W = [ I ][ V ]
+*> W = [ I ][ V ]
*> [ I ] <- identity, N-by-N
*> [ V ] <- M-by-N, same form as B.
*>
*> Thus, all of information needed for W is contained on exit in B, which
-*> we call V above. Note that V has the same form as B; that is,
+*> we call V above. Note that V has the same form as B; that is,
*>
-*> W = [ V1 ][ V2 ]
+*> W = [ V1 ][ V2 ]
*> [ V1 ] <- M-by-(N-L) rectangular
*> [ V2 ] <- M-by-L lower trapezoidal.
*>
-*> The rows of V represent the vectors which define the H(i)'s.
+*> The rows of V represent the vectors which define the H(i)'s.
*> The (M+N)-by-(M+N) block reflector H is then given by
*>
*> H = I - W**T * T * W
* Quick return if possible
*
IF( N.EQ.0 .OR. M.EQ.0 ) RETURN
-*
+*
DO I = 1, M
*
* Generate elementary reflector H(I) to annihilate B(I,:)
DO J = 1, M-I
T( M, J ) = (A( I+J, I ))
END DO
- CALL ZGEMV( 'N', M-I, P, ONE, B( I+1, 1 ), LDB,
+ CALL ZGEMV( 'N', M-I, P, ONE, B( I+1, 1 ), LDB,
$ B( I, 1 ), LDB, ONE, T( M, 1 ), LDT )
*
* C(I+1:M,I:N) = C(I+1:M,I:N) + alpha * C(I,I:N)*W(M-1:1)^H
*
* Rectangular part of B2
*
- CALL ZGEMV( 'N', I-1-P, L, ALPHA, B( MP, NP ), LDB,
+ CALL ZGEMV( 'N', I-1-P, L, ALPHA, B( MP, NP ), LDB,
$ B( I, NP ), LDB, ZERO, T( I,MP ), LDT )
*
* B1
*
- CALL ZGEMV( 'N', I-1, N-L, ALPHA, B, LDB, B( I, 1 ), LDB,
- $ ONE, T( I, 1 ), LDT )
+ CALL ZGEMV( 'N', I-1, N-L, ALPHA, B, LDB, B( I, 1 ), LDB,
+ $ ONE, T( I, 1 ), LDT )
*
-
+
*
* T(1:I-1,I) := T(1:I-1,1:I-1) * T(I,1:I-1)
*
END DO
DO J = 1, N-L+P
B(I,J)=CONJG(B(I,J))
- END DO
+ END DO
*
* T(I,I) = tau(I)
*
T(J,I)=ZERO
END DO
END DO
-
+
*
* End of ZTPLQT2
*
*
* =========== DOCUMENTATION ===========
*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
-*> Download DTPMQRT + dependencies
-*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ztpmlqt.f">
-*> [TGZ]</a>
-*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ztpmlqt.f">
-*> [ZIP]</a>
-*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ztpmlqt.f">
+*> Download DTPMQRT + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ztpmlqt.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ztpmlqt.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ztpmlqt.f">
*> [TXT]</a>
-*> \endhtmlonly
+*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZTPMLQT( SIDE, TRANS, M, N, K, L, MB, V, LDV, T, LDT,
* A, LDA, B, LDB, WORK, INFO )
-*
+*
* .. Scalar Arguments ..
* CHARACTER SIDE, TRANS
* INTEGER INFO, K, LDV, LDA, LDB, M, N, L, MB, LDT
* ..
* .. Array Arguments ..
-* COMPLEX*16 V( LDV, * ), A( LDA, * ), B( LDB, * ),
+* COMPLEX*16 V( LDV, * ), A( LDA, * ), B( LDB, * ),
* $ T( LDT, * ), WORK( * )
* ..
-*
+*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
-*> ZTPMQRT applies a complex orthogonal matrix Q obtained from a
+*> ZTPMQRT applies a complex orthogonal matrix Q obtained from a
*> "triangular-pentagonal" real block reflector H to a general
*> real matrix C, which consists of two blocks A and B.
*> \endverbatim
*> N is INTEGER
*> The number of columns of the matrix B. N >= 0.
*> \endverbatim
-*>
+*>
*> \param[in] K
*> \verbatim
*> K is INTEGER
*> \param[in] L
*> \verbatim
*> L is INTEGER
-*> The order of the trapezoidal part of V.
+*> The order of the trapezoidal part of V.
*> K >= L >= 0. See Further Details.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX*16 array, dimension
-*> (LDA,N) if SIDE = 'L' or
+*> (LDA,N) if SIDE = 'L' or
*> (LDA,K) if SIDE = 'R'
*> On entry, the K-by-N or M-by-K matrix A.
-*> On exit, A is overwritten by the corresponding block of
+*> On exit, A is overwritten by the corresponding block of
*> Q*C or Q**C*C or C*Q or C*Q**C. See Further Details.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
-*> The leading dimension of the array A.
+*> The leading dimension of the array A.
*> If SIDE = 'L', LDC >= max(1,K);
-*> If SIDE = 'R', LDC >= max(1,M).
+*> If SIDE = 'R', LDC >= max(1,M).
*> \endverbatim
*>
*> \param[in,out] B
*> \param[in] LDB
*> \verbatim
*> LDB is INTEGER
-*> The leading dimension of the array B.
+*> The leading dimension of the array B.
*> LDB >= max(1,M).
*> \endverbatim
*>
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
*> \date November 2015
*
*> \verbatim
*>
*> The columns of the pentagonal matrix V contain the elementary reflectors
-*> H(1), H(2), ..., H(K); V is composed of a rectangular block V1 and a
+*> H(1), H(2), ..., H(K); V is composed of a rectangular block V1 and a
*> trapezoidal block V2:
*>
*> V = [V1] [V2].
-*>
*>
-*> The size of the trapezoidal block V2 is determined by the parameter L,
+*>
+*> The size of the trapezoidal block V2 is determined by the parameter L,
*> where 0 <= L <= K; V2 is lower trapezoidal, consisting of the first L
*> rows of a K-by-K upper triangular matrix. If L=K, V2 is lower triangular;
*> if L=0, there is no trapezoidal block, hence V = V1 is rectangular.
*>
-*> If SIDE = 'L': C = [A] where A is K-by-N, B is M-by-N and V is K-by-M.
-*> [B]
-*>
+*> If SIDE = 'L': C = [A] where A is K-by-N, B is M-by-N and V is K-by-M.
+*> [B]
+*>
*> If SIDE = 'R': C = [A B] where A is M-by-K, B is M-by-N and V is K-by-N.
*>
*> The real orthogonal matrix Q is formed from V and T.
INTEGER INFO, K, LDV, LDA, LDB, M, N, L, MB, LDT
* ..
* .. Array Arguments ..
- COMPLEX*16 V( LDV, * ), A( LDA, * ), B( LDB, * ),
+ COMPLEX*16 V( LDV, * ), A( LDA, * ), B( LDB, * ),
$ T( LDT, * ), WORK( * )
* ..
*
RIGHT = LSAME( SIDE, 'R' )
TRAN = LSAME( TRANS, 'C' )
NOTRAN = LSAME( TRANS, 'N' )
-*
+*
IF ( LEFT ) THEN
LDAQ = MAX( 1, K )
ELSE IF ( RIGHT ) THEN
ELSE IF( K.LT.0 ) THEN
INFO = -5
ELSE IF( L.LT.0 .OR. L.GT.K ) THEN
- INFO = -6
+ INFO = -6
ELSE IF( MB.LT.1 .OR. (MB.GT.K .AND. K.GT.0) ) THEN
INFO = -7
ELSE IF( LDV.LT.K ) THEN
ELSE
LB = 0
END IF
- CALL ZTPRFB( 'L', 'C', 'F', 'R', NB, N, IB, LB,
- $ V( I, 1 ), LDV, T( 1, I ), LDT,
+ CALL ZTPRFB( 'L', 'C', 'F', 'R', NB, N, IB, LB,
+ $ V( I, 1 ), LDV, T( 1, I ), LDT,
$ A( I, 1 ), LDA, B, LDB, WORK, IB )
END DO
-*
+*
ELSE IF( RIGHT .AND. TRAN ) THEN
*
DO I = 1, K, MB
ELSE
LB = NB-N+L-I+1
END IF
- CALL ZTPRFB( 'R', 'N', 'F', 'R', M, NB, IB, LB,
- $ V( I, 1 ), LDV, T( 1, I ), LDT,
+ CALL ZTPRFB( 'R', 'N', 'F', 'R', M, NB, IB, LB,
+ $ V( I, 1 ), LDV, T( 1, I ), LDT,
$ A( 1, I ), LDA, B, LDB, WORK, M )
END DO
*
*
KF = ((K-1)/MB)*MB+1
DO I = KF, 1, -MB
- IB = MIN( MB, K-I+1 )
+ IB = MIN( MB, K-I+1 )
NB = MIN( M-L+I+IB-1, M )
IF( I.GE.L ) THEN
LB = 0
ELSE
LB = 0
- END IF
+ END IF
CALL ZTPRFB( 'L', 'N', 'F', 'R', NB, N, IB, LB,
- $ V( I, 1 ), LDV, T( 1, I ), LDT,
+ $ V( I, 1 ), LDV, T( 1, I ), LDT,
$ A( I, 1 ), LDA, B, LDB, WORK, IB )
END DO
*
*
KF = ((K-1)/MB)*MB+1
DO I = KF, 1, -MB
- IB = MIN( MB, K-I+1 )
+ IB = MIN( MB, K-I+1 )
NB = MIN( N-L+I+IB-1, N )
IF( I.GE.L ) THEN
LB = 0
LB = NB-N+L-I+1
END IF
CALL ZTPRFB( 'R', 'C', 'F', 'R', M, NB, IB, LB,
- $ V( I, 1 ), LDV, T( 1, I ), LDT,
+ $ V( I, 1 ), LDV, T( 1, I ), LDT,
$ A( 1, I ), LDA, B, LDB, WORK, M )
END DO
*
*
ELSE IF( LSAMEN( 2, P2, 'HA' ) ) THEN
*
-* HA: Hermitian
+* HA: Hermitian
* Aasen algorithm
WRITE( IOUNIT, FMT = 9971 )PATH, 'Hermitian'
*
WRITE( IOUNIT, FMT = 9978 )5
WRITE( IOUNIT, FMT = 9976 )6
WRITE( IOUNIT, FMT = '( '' Messages:'' )' )
-
-
- ELSE IF( LSAMEN( 2, P2, 'HE' ) .OR.
+
+
+ ELSE IF( LSAMEN( 2, P2, 'HE' ) .OR.
$ LSAMEN( 2, P2, 'HP' ) ) THEN
*
* HE: Hermitian indefinite full
*
IF( TSTCHK ) THEN
CALL CCHKHE_AASEN( DOTYPE, NN, NVAL, NNB2, NBVAL2, NNS,
- $ NSVAL, THRESH, TSTERR, LDA,
+ $ NSVAL, THRESH, TSTERR, LDA,
$ A( 1, 1 ), A( 1, 2 ), A( 1, 3 ),
$ B( 1, 1 ), B( 1, 2 ), B( 1, 3 ),
$ WORK, RWORK, IWORK, NOUT )
END IF
*
IF( TSTDRV ) THEN
- CALL CDRVHE_AASEN( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR,
- $ LDA, A( 1, 1 ), A( 1, 2 ), A( 1, 3 ),
- $ B( 1, 1 ), B( 1, 2 ), B( 1, 3 ),
+ CALL CDRVHE_AASEN( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR,
+ $ LDA, A( 1, 1 ), A( 1, 2 ), A( 1, 3 ),
+ $ B( 1, 1 ), B( 1, 2 ), B( 1, 3 ),
$ WORK, RWORK, IWORK, NOUT )
ELSE
WRITE( NOUT, FMT = 9988 )PATH
* QX: QRT routines for triangular-pentagonal matrices
*
IF( TSTCHK ) THEN
- CALL CCHKQRTP( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
+ CALL CCHKQRTP( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
$ NBVAL, NOUT )
ELSE
WRITE( NOUT, FMT = 9989 )PATH
* TQ: LQT routines for general matrices
*
IF( TSTCHK ) THEN
- CALL CCHKLQT( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
+ CALL CCHKLQT( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
$ NBVAL, NOUT )
ELSE
WRITE( NOUT, FMT = 9989 )PATH
* XQ: LQT routines for triangular-pentagonal matrices
*
IF( TSTCHK ) THEN
- CALL CCHKLQTP( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
+ CALL CCHKLQTP( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
$ NBVAL, NOUT )
ELSE
WRITE( NOUT, FMT = 9989 )PATH
* TS: QR routines for tall-skinny matrices
*
IF( TSTCHK ) THEN
- CALL CCHKTSQR( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
+ CALL CCHKTSQR( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
$ NBVAL, NOUT )
ELSE
WRITE( NOUT, FMT = 9989 )PATH
* .. External Subroutines ..
EXTERNAL ALAERH, ALAHD, ALASUM, XLAENV, CERRHE, CGET04,
$ ZHECON, CHERFS, CHET01, CHETRF_AASEN, ZHETRI2,
- $ CHETRS_AASEN, CLACPY, CLAIPD, CLARHS, CLATB4,
+ $ CHETRS_AASEN, CLACPY, CLAIPD, CLARHS, CLATB4,
$ CLATMS, CPOT02, ZPOT03, ZPOT05
* ..
* .. Intrinsic Functions ..
*
LWORK = ( NB+1 )*LDA
SRNAMT = 'CHETRF_AASEN'
- CALL CHETRF_AASEN( UPLO, N, AFAC, LDA, IWORK, AINV,
+ CALL CHETRF_AASEN( UPLO, N, AFAC, LDA, IWORK, AINV,
$ LWORK, INFO )
*
* Adjust the expected value of INFO to account for
* Check error code from CHETRF and handle error.
*
IF( INFO.NE.K ) THEN
- CALL ALAERH( PATH, 'CHETRF_AASEN', INFO, K, UPLO,
- $ N, N, -1, -1, NB, IMAT, NFAIL, NERRS,
+ CALL ALAERH( PATH, 'CHETRF_AASEN', INFO, K, UPLO,
+ $ N, N, -1, -1, NB, IMAT, NFAIL, NERRS,
$ NOUT )
END IF
*
*
* =========== DOCUMENTATION ===========
*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
-* SUBROUTINE CCHKLQT( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
+* SUBROUTINE CCHKLQT( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
* NBVAL, NOUT )
-*
+*
* .. Scalar Arguments ..
* LOGICAL TSTERR
* INTEGER NM, NN, NNB, NOUT
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup double_lin
*
* =====================================================================
- SUBROUTINE CCHKLQT( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
+ SUBROUTINE CCHKLQT( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
$ NBVAL, NOUT )
IMPLICIT NONE
*
NB = NBVAL( K )
*
* Test CGELQT and CUNMLQT
-*
+*
IF( (NB.LE.MINMN).AND.(NB.GT.0) ) THEN
CALL CLQT04( M, N, NB, RESULT )
*
*
* =========== DOCUMENTATION ===========
*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
-* SUBROUTINE CCHKLQTP( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
+* SUBROUTINE CCHKLQTP( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
* NBVAL, NOUT )
*
* .. Scalar Arguments ..
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup double_lin
*
* =====================================================================
- SUBROUTINE CCHKLQTP( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
+ SUBROUTINE CCHKLQTP( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
$ NBVAL, NOUT )
IMPLICIT NONE
*
*
MINMN = MIN( M, N )
DO L = 0, MINMN, MAX( MINMN, 1 )
-*
+*
* Do for each possible value of NB
*
DO K = 1, NNB
NB = NBVAL( K )
*
* Test DTPLQT and DTPMLQT
-*
+*
IF( (NB.LE.M).AND.(NB.GT.0) ) THEN
CALL CLQT05( M, N, L, NB, RESULT )
*
*
* End of CCHKLQTP
*
- END
\ No newline at end of file
+ END
*
* =========== DOCUMENTATION ===========
*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
-* SUBROUTINE CCHKTSQR( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
+* SUBROUTINE CCHKTSQR( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
* NBVAL, NOUT )
-*
+*
* .. Scalar Arguments ..
* LOGICAL TSTERR
* INTEGER NM, NN, NNB, NOUT
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup double_lin
*
* =====================================================================
- SUBROUTINE CCHKTSQR( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
+ SUBROUTINE CCHKTSQR( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
$ NBVAL, NOUT )
IMPLICIT NONE
*
REAL RESULT( NTESTS )
* ..
* .. External Subroutines ..
- EXTERNAL ALAERH, ALAHD, ALASUM, CERRTSQR,
+ EXTERNAL ALAERH, ALAHD, ALASUM, CERRTSQR,
$ CTSQR01, XLAENV
* ..
* .. Intrinsic Functions ..
- INTRINSIC MAX, MIN
+ INTRINSIC MAX, MIN
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
DO J = 1, NN
N = NVAL( J )
IF (MIN(M,N).NE.0) THEN
- DO INB = 1, NNB
+ DO INB = 1, NNB
MB = NBVAL( INB )
CALL XLAENV( 1, MB )
DO IMB = 1, NNB
CALL XLAENV( 2, NB )
*
* Test DGEQR and DGEMQR
-*
+*
CALL CTSQR01( 'TS', M, N, MB, NB, RESULT )
*
* Print information about the tests that did not
END IF
END DO
NRUN = NRUN + NTESTS
- END DO
- END DO
- END IF
+ END DO
+ END DO
+ END IF
END DO
END DO
*
DO J = 1, NN
N = NVAL( J )
IF (MIN(M,N).NE.0) THEN
- DO INB = 1, NNB
+ DO INB = 1, NNB
MB = NBVAL( INB )
CALL XLAENV( 1, MB )
DO IMB = 1, NNB
CALL XLAENV( 2, NB )
*
* Test DGEQR and DGEMQR
-*
+*
CALL CTSQR01( 'SW', M, N, MB, NB, RESULT )
*
* Print information about the tests that did not
END IF
END DO
NRUN = NRUN + NTESTS
- END DO
- END DO
- END IF
+ END DO
+ END DO
+ END IF
END DO
END DO
*
END IF
*
* Check error code from CHESV_AASEN .
-*
+*
IF( INFO.NE.K ) THEN
- CALL ALAERH( PATH, 'CHESV_AASEN', INFO, K,
- $ UPLO, N, N, -1, -1, NRHS,
+ CALL ALAERH( PATH, 'CHESV_AASEN', INFO, K,
+ $ UPLO, N, N, -1, -1, NRHS,
$ IMAT, NFAIL, NERRS, NOUT )
GO TO 120
ELSE IF( INFO.NE.0 ) THEN
* residual.
*
CALL CHET01_AASEN( UPLO, N, A, LDA, AFAC, LDA,
- $ IWORK, AINV, LDA, RWORK,
+ $ IWORK, AINV, LDA, RWORK,
$ RESULT( 1 ) )
*
* Compute residual of the computed solution.
* ..
* .. External Subroutines ..
EXTERNAL ALAERH, ALAHD, ALASVM, CERRLS, CGELS, CGELSD,
- $ CGELSS, CGELSY, CGEMM, CGETSLS, CLACPY,
- $ CLARNV, CQRT13, CQRT15, CQRT16, CSSCAL,
+ $ CGELSS, CGELSY, CGEMM, CGETSLS, CLACPY,
+ $ CLARNV, CQRT13, CQRT15, CQRT16, CSSCAL,
$ SAXPY, XLAENV
* ..
* .. Intrinsic Functions ..
$ COPYB, LDB, B, LDB )
END IF
SRNAMT = 'DGETSLS '
- CALL CGETSLS( TRANS, M, N, NRHS, A,
+ CALL CGETSLS( TRANS, M, N, NRHS, A,
$ LDA, B, LDB, WORK, LWORK, INFO )
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'CGETSLS ', INFO, 0,
$ ', NB=', I4, ', type', I2, ', test(', I2, ')=', G12.5 )
9998 FORMAT( ' M=', I5, ', N=', I5, ', NRHS=', I4, ', NB=', I4,
$ ', type', I2, ', test(', I2, ')=', G12.5 )
- 9997 FORMAT( ' TRANS=''', A1,' M=', I5, ', N=', I5, ', NRHS=', I4,
- $ ', MB=', I4,', NB=', I4,', type', I2,
+ 9997 FORMAT( ' TRANS=''', A1,' M=', I5, ', N=', I5, ', NRHS=', I4,
+ $ ', MB=', I4,', NB=', I4,', type', I2,
$ ', test(', I2, ')=', G12.5 )
RETURN
*
*
* =========== DOCUMENTATION ===========
*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE CERRLQT( PATH, NUNIT )
-*
+*
* .. Scalar Arguments ..
* CHARACTER*3 PATH
* INTEGER NUNIT
* ..
-*
+*
*
*> \par Purpose:
* =============
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
*> \date November 2011
*
* ..
* .. External Subroutines ..
EXTERNAL ALAESM, CHKXER, CGELQT3, CGELQT,
- $ CGEMLQT
+ $ CGEMLQT
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
*
* =========== DOCUMENTATION ===========
*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE CERRLQTP( PATH, NUNIT )
-*
+*
* .. Scalar Arguments ..
* CHARACTER*3 PATH
* INTEGER NUNIT
* ..
-*
+*
*
*> \par Purpose:
* =============
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
*> \date November 2011
*
* ..
* .. External Subroutines ..
EXTERNAL ALAESM, CHKXER, CTPLQT2, CTPLQT,
- $ CTPMLQT
+ $ CTPMLQT
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
*
SRNAMT = 'CTPMLQT'
INFOT = 1
- CALL CTPMLQT( '/', 'N', 0, 0, 0, 0, 1, A, 1, T, 1, B, 1, C, 1,
+ CALL CTPMLQT( '/', 'N', 0, 0, 0, 0, 1, A, 1, T, 1, B, 1, C, 1,
$ W, INFO )
CALL CHKXER( 'CTPMLQT', INFOT, NOUT, LERR, OK )
INFOT = 2
- CALL CTPMLQT( 'L', '/', 0, 0, 0, 0, 1, A, 1, T, 1, B, 1, C, 1,
+ CALL CTPMLQT( 'L', '/', 0, 0, 0, 0, 1, A, 1, T, 1, B, 1, C, 1,
$ W, INFO )
CALL CHKXER( 'CTPMLQT', INFOT, NOUT, LERR, OK )
INFOT = 3
- CALL CTPMLQT( 'L', 'N', -1, 0, 0, 0, 1, A, 1, T, 1, B, 1, C, 1,
+ CALL CTPMLQT( 'L', 'N', -1, 0, 0, 0, 1, A, 1, T, 1, B, 1, C, 1,
$ W, INFO )
CALL CHKXER( 'CTPMLQT', INFOT, NOUT, LERR, OK )
INFOT = 4
- CALL CTPMLQT( 'L', 'N', 0, -1, 0, 0, 1, A, 1, T, 1, B, 1, C, 1,
+ CALL CTPMLQT( 'L', 'N', 0, -1, 0, 0, 1, A, 1, T, 1, B, 1, C, 1,
$ W, INFO )
CALL CHKXER( 'CTPMLQT', INFOT, NOUT, LERR, OK )
INFOT = 5
- CALL CTPMLQT( 'L', 'N', 0, 0, -1, 0, 1, A, 1, T, 1, B, 1, C, 1,
+ CALL CTPMLQT( 'L', 'N', 0, 0, -1, 0, 1, A, 1, T, 1, B, 1, C, 1,
$ W, INFO )
INFOT = 6
- CALL CTPMLQT( 'L', 'N', 0, 0, 0, -1, 1, A, 1, T, 1, B, 1, C, 1,
+ CALL CTPMLQT( 'L', 'N', 0, 0, 0, -1, 1, A, 1, T, 1, B, 1, C, 1,
$ W, INFO )
CALL CHKXER( 'CTPMLQT', INFOT, NOUT, LERR, OK )
INFOT = 7
- CALL CTPMLQT( 'L', 'N', 0, 0, 0, 0, 0, A, 1, T, 1, B, 1, C, 1,
+ CALL CTPMLQT( 'L', 'N', 0, 0, 0, 0, 0, A, 1, T, 1, B, 1, C, 1,
$ W, INFO )
CALL CHKXER( 'CTPMLQT', INFOT, NOUT, LERR, OK )
INFOT = 9
- CALL CTPMLQT( 'R', 'N', 2, 2, 2, 1, 1, A, 1, T, 1, B, 1, C, 1,
+ CALL CTPMLQT( 'R', 'N', 2, 2, 2, 1, 1, A, 1, T, 1, B, 1, C, 1,
$ W, INFO )
CALL CHKXER( 'CTPMLQT', INFOT, NOUT, LERR, OK )
INFOT = 11
- CALL CTPMLQT( 'R', 'N', 1, 1, 1, 1, 1, A, 1, T, 0, B, 1, C, 1,
+ CALL CTPMLQT( 'R', 'N', 1, 1, 1, 1, 1, A, 1, T, 0, B, 1, C, 1,
$ W, INFO )
CALL CHKXER( 'CTPMLQT', INFOT, NOUT, LERR, OK )
INFOT = 13
- CALL CTPMLQT( 'L', 'N', 1, 1, 1, 1, 1, A, 1, T, 1, B, 0, C, 1,
+ CALL CTPMLQT( 'L', 'N', 1, 1, 1, 1, 1, A, 1, T, 1, B, 0, C, 1,
$ W, INFO )
CALL CHKXER( 'CTPMLQT', INFOT, NOUT, LERR, OK )
INFOT = 15
- CALL CTPMLQT( 'L', 'N', 1, 1, 1, 1, 1, A, 1, T, 1, B, 1, C, 0,
+ CALL CTPMLQT( 'L', 'N', 1, 1, 1, 1, 1, A, 1, T, 1, B, 1, C, 0,
$ W, INFO )
CALL CHKXER( 'CTPMLQT', INFOT, NOUT, LERR, OK )
*
*
* =========== DOCUMENTATION ===========
*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE CERRTSQR( PATH, NUNIT )
-*
+*
* .. Scalar Arguments ..
* CHARACTER*3 PATH
* INTEGER NUNIT
* ..
-*
+*
*
*> \par Purpose:
* =============
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Zenver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Zenver
+*> \author NAG Ltd.
*
*> \date November 2011
*
* Definition:
* ===========
*
-* SUBROUTINE CHET01_AASEN( UPLO, N, A, LDA, AFAC, LDAFAC, IPIV,
+* SUBROUTINE CHET01_AASEN( UPLO, N, A, LDA, AFAC, LDAFAC, IPIV,
* C, LDC, RWORK, RESID )
*
* .. Scalar Arguments ..
*
* .. Parameters ..
COMPLEX CZERO, CONE
- PARAMETER ( CZERO = ( 0.0E+0, 0.0E+0 ),
+ PARAMETER ( CZERO = ( 0.0E+0, 0.0E+0 ),
$ CONE = ( 1.0E+0, 0.0E+0 ) )
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
*
* =========== DOCUMENTATION ===========
*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE CLQT04(M,N,NB,RESULT)
-*
+*
* .. Scalar Arguments ..
* INTEGER M, N, NB
* .. Return values ..
* REAL RESULT(6)
-*
+*
*
*> \par Purpose:
* =============
*> RESULT(2) = | I - Q Q^H |
*> RESULT(3) = | Q C - Q C |
*> RESULT(4) = | Q^H C - Q^H C |
-*> RESULT(5) = | C Q - C Q |
+*> RESULT(5) = | C Q - C Q |
*> RESULT(6) = | C Q^H - C Q^H |
*> \endverbatim
*
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
*> \date April 2012
*
* =====================================================================
*
* ..
-* .. Local allocatable arrays
+* .. Local allocatable arrays
COMPLEX, ALLOCATABLE :: AF(:,:), Q(:,:),
- $ L(:,:), RWORK(:), WORK( : ), T(:,:),
+ $ L(:,:), RWORK(:), WORK( : ), T(:,:),
$ CF(:,:), DF(:,:), A(:,:), C(:,:), D(:,:)
*
* .. Parameters ..
EXTERNAL SLAMCH, CLANGE, CLANSY, LSAME
* ..
* .. Intrinsic Functions ..
- INTRINSIC MAX, MIN
+ INTRINSIC MAX, MIN
* ..
* .. Data statements ..
- DATA ISEED / 1988, 1989, 1990, 1991 /
-*
+ DATA ISEED / 1988, 1989, 1990, 1991 /
+*
EPS = SLAMCH( 'Epsilon' )
K = MIN(M,N)
LL = MAX(M,N)
*
* Dynamically allocate local arrays
*
- ALLOCATE ( A(M,N), AF(M,N), Q(N,N), L(LL,N), RWORK(LL),
- $ WORK(LWORK), T(NB,N), C(M,N), CF(M,N),
+ ALLOCATE ( A(M,N), AF(M,N), Q(N,N), L(LL,N), RWORK(LL),
+ $ WORK(LWORK), T(NB,N), C(M,N), CF(M,N),
$ D(N,M), DF(N,M) )
*
* Put random numbers into A and copy to AF
* Generate the n-by-n matrix Q
*
CALL CLASET( 'Full', N, N, CZERO, ONE, Q, N )
- CALL CGEMLQT( 'R', 'N', N, N, K, NB, AF, M, T, LDT, Q, N,
+ CALL CGEMLQT( 'R', 'N', N, N, K, NB, AF, M, T, LDT, Q, N,
$ WORK, INFO )
*
* Copy L
*
* Apply Q to C as Q*C
*
- CALL CGEMLQT( 'L', 'N', N, M, K, NB, AF, M, T, NB, DF, N,
+ CALL CGEMLQT( 'L', 'N', N, M, K, NB, AF, M, T, NB, DF, N,
$ WORK, INFO)
*
* Compute |Q*D - Q*D| / |D|
*
* Apply Q to D as QT*D
*
- CALL CGEMLQT( 'L', 'C', N, M, K, NB, AF, M, T, NB, DF, N,
+ CALL CGEMLQT( 'L', 'C', N, M, K, NB, AF, M, T, NB, DF, N,
$ WORK, INFO)
*
* Compute |QT*D - QT*D| / |D|
RESULT( 4 ) = RESID / (EPS*MAX(1,M)*DNORM)
ELSE
RESULT( 4 ) = ZERO
- END IF
+ END IF
*
* Generate random n-by-m matrix D and a copy DF
*
*
* Apply Q to C as C*Q
*
- CALL CGEMLQT( 'R', 'N', M, N, K, NB, AF, M, T, NB, CF, M,
- $ WORK, INFO)
+ CALL CGEMLQT( 'R', 'N', M, N, K, NB, AF, M, T, NB, CF, M,
+ $ WORK, INFO)
*
* Compute |C*Q - C*Q| / |C|
*
*
* Apply Q to D as D*QT
*
- CALL CGEMLQT( 'R', 'C', M, N, K, NB, AF, M, T, NB, CF, M,
- $ WORK, INFO)
+ CALL CGEMLQT( 'R', 'C', M, N, K, NB, AF, M, T, NB, CF, M,
+ $ WORK, INFO)
*
* Compute |C*QT - C*QT| / |C|
*
*
* =========== DOCUMENTATION ===========
*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE CLQT05(M,N,L,NB,RESULT)
-*
+*
* .. Scalar Arguments ..
* INTEGER LWORK, M, N, L, NB, LDT
* .. Return values ..
* DOUBLE PRECISION RESULT(6)
-*
+*
*
*> \par Purpose:
* =============
*> The number of rows of the upper trapezoidal part the
*> lower test matrix. 0 <= L <= M.
*> \endverbatim
-*>
+*>
*> \param[in] NB
*> \verbatim
*> NB is INTEGER
*> RESULT(2) = | I - Q^H Q |
*> RESULT(3) = | Q C - Q C |
*> RESULT(4) = | Q^H C - Q^H C |
-*> RESULT(5) = | C Q - C Q |
+*> RESULT(5) = | C Q - C Q |
*> RESULT(6) = | C Q^H - C Q^H |
*> \endverbatim
*
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
*> \date April 2012
*
REAL RESULT(6)
*
* =====================================================================
-*
+*
* ..
-* .. Local allocatable arrays
+* .. Local allocatable arrays
COMPLEX, ALLOCATABLE :: AF(:,:), Q(:,:),
- $ R(:,:), RWORK(:), WORK( : ), T(:,:),
+ $ R(:,:), RWORK(:), WORK( : ), T(:,:),
$ CF(:,:), DF(:,:), A(:,:), C(:,:), D(:,:)
*
* .. Parameters ..
* ..
* .. Data statements ..
DATA ISEED / 1988, 1989, 1990, 1991 /
-*
+*
EPS = SLAMCH( 'Epsilon' )
K = M
N2 = M+N
* Dynamically allocate all arrays
*
ALLOCATE(A(M,N2),AF(M,N2),Q(N2,N2),R(N2,N2),RWORK(N2),
- $ WORK(LWORK),T(NB,M),C(N2,M),CF(N2,M),
+ $ WORK(LWORK),T(NB,M),C(N2,M),CF(N2,M),
$ D(M,N2),DF(M,N2) )
*
* Put random stuff into A
END IF
IF( L.GT.0 ) THEN
DO J=1,L
- CALL CLARNV( 2, ISEED, M-J+1, A( J, MIN(N+M,N+M-L+1)
+ CALL CLARNV( 2, ISEED, M-J+1, A( J, MIN(N+M,N+M-L+1)
$ + J - 1 ) )
END DO
END IF
CALL CLACPY( 'Full', N2, M, C, N2, CF, N2 )
*
* Apply Q to C as Q*C
-*
+*
CALL CTPMLQT( 'L','N', N,M,K,L,NB,AF(1, NP1),M,T,LDT,CF,N2,
$ CF(NP1,1),N2,WORK,INFO)
*
* Apply Q to C as QT*C
*
CALL CTPMLQT( 'L','C',N,M,K,L,NB,AF(1,NP1),M,T,LDT,CF,N2,
- $ CF(NP1,1),N2,WORK,INFO)
+ $ CF(NP1,1),N2,WORK,INFO)
*
* Compute |QT*C - QT*C| / |C|
*
CALL CGEMM('C','N',N2,M,N2,-ONE,Q,N2,C,N2,ONE,CF,N2)
RESID = CLANGE( '1', N2, M, CF, N2, RWORK )
-
+
IF( CNORM.GT.ZERO ) THEN
RESULT( 4 ) = RESID / (EPS*MAX(1,N2)*CNORM)
ELSE
RESULT( 4 ) = ZERO
- END IF
+ END IF
*
* Generate random m-by-n matrix D and a copy DF
*
* Apply Q to D as D*QT
*
CALL CTPMLQT('R','C',M,N,K,L,NB,AF(1,NP1),M,T,LDT,DF,M,
- $ DF(1,NP1),M,WORK,INFO)
-
+ $ DF(1,NP1),M,WORK,INFO)
+
*
* Compute |D*QT - D*QT| / |D|
*
*
DEALLOCATE ( A, AF, Q, R, RWORK, WORK, T, C, D, CF, DF)
RETURN
- END
\ No newline at end of file
+ END
*
* =========== DOCUMENTATION ===========
*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE CTSQR01(TSSW, M,N, MB, NB, RESULT)
-*
+*
* .. Scalar Arguments ..
* INTEGER M, N, MB
* .. Return values ..
* REAL RESULT(6)
-*
+*
*
*> \par Purpose:
* =============
*> RESULT(2) = | I - Q^H Q | or | I - Q Q^H |
*> RESULT(3) = | Q C - Q C |
*> RESULT(4) = | Q^H C - Q^H C |
-*> RESULT(5) = | C Q - C Q |
+*> RESULT(5) = | C Q - C Q |
*> RESULT(6) = | C Q^H - C Q^H |
*> \endverbatim
*
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
*> \date April 2012
*
* =====================================================================
*
* ..
-* .. Local allocatable arrays
+* .. Local allocatable arrays
COMPLEX, ALLOCATABLE :: AF(:,:), Q(:,:),
- $ R(:,:), RWORK(:), WORK( : ), T(:),
+ $ R(:,:), RWORK(:), WORK( : ), T(:),
$ CF(:,:), DF(:,:), A(:,:), C(:,:), D(:,:), LQ(:,:)
*
* .. Parameters ..
EXTERNAL SLAMCH, CLANGE, CLANSY, LSAME, ILAENV
* ..
* .. Intrinsic Functions ..
- INTRINSIC MAX, MIN
+ INTRINSIC MAX, MIN
* .. Scalars in Common ..
CHARACTER*32 srnamt
* ..
* .. Common blocks ..
- COMMON / srnamc / srnamt
+ COMMON / srnamc / srnamt
* ..
* .. Data statements ..
- DATA ISEED / 1988, 1989, 1990, 1991 /
+ DATA ISEED / 1988, 1989, 1990, 1991 /
*
* TEST TALL SKINNY OR SHORT WIDE
*
- TS = LSAME(TSSW, 'TS')
-*
+ TS = LSAME(TSSW, 'TS')
+*
* TEST MATRICES WITH HALF OF MATRIX BEING ZEROS
*
TESTZEROS = .FALSE.
-*
+*
EPS = SLAMCH( 'Epsilon' )
K = MIN(M,N)
L = MAX(M,N,1)
IF((K.GE.MNB).OR.(MNB.GE.L))THEN
LT=MAX(1,L)*MNB+5
ELSE
- LT=MAX(1,(L-K)/(MNB-K)+1)*L*MNB+5
+ LT=MAX(1,(L-K)/(MNB-K)+1)*L*MNB+5
END IF
*
* Dynamically allocate local arrays
*
- ALLOCATE ( A(M,N), AF(M,N), Q(L,L), R(M,L), RWORK(L),
- $ WORK(LWORK), T(LT), C(M,N), CF(M,N),
+ ALLOCATE ( A(M,N), AF(M,N), Q(L,L), R(M,L), RWORK(L),
+ $ WORK(LWORK), T(LT), C(M,N), CF(M,N),
$ D(N,M), DF(N,M), LQ(L,N) )
*
* Put random numbers into A and copy to AF
*
CALL CLASET( 'Full', M, M, CZERO, ONE, Q, M )
srnamt = 'CGEMQR'
- CALL CGEMQR( 'L', 'N', M, M, K, AF, M, T, LT, Q, M,
+ CALL CGEMQR( 'L', 'N', M, M, K, AF, M, T, LT, Q, M,
$ WORK, LWORK, INFO )
*
* Copy R
* Apply Q to C as Q*C
*
srnamt = 'CGEMQR'
- CALL CGEMQR( 'L', 'N', M, N, K, AF, M, T, LT, CF, M,
+ CALL CGEMQR( 'L', 'N', M, N, K, AF, M, T, LT, CF, M,
$ WORK, LWORK, INFO)
*
* Compute |Q*C - Q*C| / |C|
* Apply Q to C as QT*C
*
srnamt = 'CGEMQR'
- CALL CGEMQR( 'L', 'C', M, N, K, AF, M, T, LT, CF, M,
+ CALL CGEMQR( 'L', 'C', M, N, K, AF, M, T, LT, CF, M,
$ WORK, LWORK, INFO)
*
* Compute |QT*C - QT*C| / |C|
RESULT( 4 ) = RESID / (EPS*MAX(1,M)*CNORM)
ELSE
RESULT( 4 ) = ZERO
- END IF
+ END IF
*
* Generate random n-by-m matrix D and a copy DF
*
* Apply Q to D as D*Q
*
srnamt = 'CGEMQR'
- CALL CGEMQR( 'R', 'N', N, M, K, AF, M, T, LT, DF, N,
- $ WORK, LWORK, INFO)
+ CALL CGEMQR( 'R', 'N', N, M, K, AF, M, T, LT, DF, N,
+ $ WORK, LWORK, INFO)
*
* Compute |D*Q - D*Q| / |D|
*
*
* Apply Q to D as D*QT
*
- CALL CGEMQR( 'R', 'C', N, M, K, AF, M, T, LT, DF, N,
- $ WORK, LWORK, INFO)
+ CALL CGEMQR( 'R', 'C', N, M, K, AF, M, T, LT, DF, N,
+ $ WORK, LWORK, INFO)
*
* Compute |D*QT - D*QT| / |D|
*
*
CALL CLASET( 'Full', N, N, CZERO, ONE, Q, N )
srnamt = 'CGEMLQ'
- CALL CGEMLQ( 'R', 'N', N, N, K, AF, M, T, LT, Q, N,
+ CALL CGEMLQ( 'R', 'N', N, N, K, AF, M, T, LT, Q, N,
$ WORK, LWORK, INFO )
*
* Copy R
*
* Apply Q to C as Q*C
*
- CALL CGEMLQ( 'L', 'N', N, M, K, AF, M, T, LT, DF, N,
+ CALL CGEMLQ( 'L', 'N', N, M, K, AF, M, T, LT, DF, N,
$ WORK, LWORK, INFO)
*
* Compute |Q*D - Q*D| / |D|
*
* Apply Q to D as QT*D
*
- CALL CGEMLQ( 'L', 'C', N, M, K, AF, M, T, LT, DF, N,
+ CALL CGEMLQ( 'L', 'C', N, M, K, AF, M, T, LT, DF, N,
$ WORK, LWORK, INFO)
*
* Compute |QT*D - QT*D| / |D|
RESULT( 4 ) = RESID / (EPS*MAX(1,N)*DNORM)
ELSE
RESULT( 4 ) = ZERO
- END IF
+ END IF
*
* Generate random n-by-m matrix D and a copy DF
*
*
* Apply Q to C as C*Q
*
- CALL CGEMLQ( 'R', 'N', M, N, K, AF, M, T, LT, CF, M,
- $ WORK, LWORK, INFO)
+ CALL CGEMLQ( 'R', 'N', M, N, K, AF, M, T, LT, CF, M,
+ $ WORK, LWORK, INFO)
*
* Compute |C*Q - C*Q| / |C|
*
*
* Apply Q to D as D*QT
*
- CALL CGEMLQ( 'R', 'C', M, N, K, AF, M, T, LT, CF, M,
- $ WORK, LWORK, INFO)
+ CALL CGEMLQ( 'R', 'C', M, N, K, AF, M, T, LT, CF, M,
+ $ WORK, LWORK, INFO)
*
* Compute |C*QT - C*QT| / |C|
*
DEALLOCATE ( A, AF, Q, R, RWORK, WORK, T, C, D, CF, DF)
*
RETURN
- END
\ No newline at end of file
+ END
CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
*
IF( TSTCHK ) THEN
- CALL DCHKSY_AASEN( DOTYPE, NN, NVAL, NNB2, NBVAL2, NNS,
+ CALL DCHKSY_AASEN( DOTYPE, NN, NVAL, NNB2, NBVAL2, NNS,
$ NSVAL, THRESH, TSTERR, LDA,
- $ A( 1, 1 ), A( 1, 2 ), A( 1, 3 ),
+ $ A( 1, 1 ), A( 1, 2 ), A( 1, 3 ),
$ B( 1, 1 ), B( 1, 2 ), B( 1, 3 ),
$ WORK, RWORK, IWORK, NOUT )
ELSE
* QX: QRT routines for triangular-pentagonal matrices
*
IF( TSTCHK ) THEN
- CALL DCHKQRTP( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
+ CALL DCHKQRTP( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
$ NBVAL, NOUT )
ELSE
WRITE( NOUT, FMT = 9989 )PATH
* TQ: LQT routines for general matrices
*
IF( TSTCHK ) THEN
- CALL DCHKLQT( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
+ CALL DCHKLQT( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
$ NBVAL, NOUT )
ELSE
WRITE( NOUT, FMT = 9989 )PATH
* XQ: LQT routines for triangular-pentagonal matrices
*
IF( TSTCHK ) THEN
- CALL DCHKLQTP( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
+ CALL DCHKLQTP( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
$ NBVAL, NOUT )
ELSE
WRITE( NOUT, FMT = 9989 )PATH
* TS: QR routines for tall-skinny matrices
*
IF( TSTCHK ) THEN
- CALL DCHKTSQR( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
+ CALL DCHKTSQR( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
$ NBVAL, NOUT )
ELSE
WRITE( NOUT, FMT = 9989 )PATH
*
* =========== DOCUMENTATION ===========
*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
-* SUBROUTINE DCHKLQT( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
+* SUBROUTINE DCHKLQT( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
* NBVAL, NOUT )
-*
+*
* .. Scalar Arguments ..
* LOGICAL TSTERR
* INTEGER NM, NN, NNB, NOUT
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup double_lin
*
* =====================================================================
- SUBROUTINE DCHKLQT( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
+ SUBROUTINE DCHKLQT( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
$ NBVAL, NOUT )
IMPLICIT NONE
*
NB = NBVAL( K )
*
* Test DGELQT and DGEMLQT
-*
+*
IF( (NB.LE.MINMN).AND.(NB.GT.0) ) THEN
CALL DLQT04( M, N, NB, RESULT )
*
*
* =========== DOCUMENTATION ===========
*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
-* SUBROUTINE DCHKLQTP( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
+* SUBROUTINE DCHKLQTP( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
* NBVAL, NOUT )
*
* .. Scalar Arguments ..
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup double_lin
*
* =====================================================================
- SUBROUTINE DCHKLQTP( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
+ SUBROUTINE DCHKLQTP( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
$ NBVAL, NOUT )
IMPLICIT NONE
*
*
MINMN = MIN( M, N )
DO L = 0, MINMN, MAX( MINMN, 1 )
-*
+*
* Do for each possible value of NB
*
DO K = 1, NNB
NB = NBVAL( K )
*
* Test DTPLQT and DTPMLQT
-*
+*
IF( (NB.LE.M).AND.(NB.GT.0) ) THEN
CALL DLQT05( M, N, L, NB, RESULT )
*
*
SRNAMT = 'DSYTRF_AASEN'
LWORK = N*NB + N
- CALL DSYTRF_AASEN( UPLO, N, AFAC, LDA, IWORK, AINV,
+ CALL DSYTRF_AASEN( UPLO, N, AFAC, LDA, IWORK, AINV,
$ LWORK, INFO )
*
* Adjust the expected value of INFO to account for
* Check error code from DSYTRF and handle error.
*
IF( INFO.NE.K ) THEN
- CALL ALAERH( PATH, 'DSYTRF_AASEN', INFO, K, UPLO,
- $ N, N, -1, -1, NB, IMAT, NFAIL, NERRS,
+ CALL ALAERH( PATH, 'DSYTRF_AASEN', INFO, K, UPLO,
+ $ N, N, -1, -1, NB, IMAT, NFAIL, NERRS,
$ NOUT )
END IF
*
*
SRNAMT = 'DSYTRS_AASEN'
LWORK = 3*N-2
- CALL DSYTRS_AASEN( UPLO, N, NRHS, AFAC, LDA,
+ CALL DSYTRS_AASEN( UPLO, N, NRHS, AFAC, LDA,
$ IWORK, X, LDA, WORK, LWORK,
$ INFO )
*
*
* =========== DOCUMENTATION ===========
*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
-* SUBROUTINE DCHKTSQR( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
+* SUBROUTINE DCHKTSQR( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
* NBVAL, NOUT )
-*
+*
* .. Scalar Arguments ..
* LOGICAL TSTERR
* INTEGER NM, NN, NNB, NOUT
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup double_lin
*
* =====================================================================
- SUBROUTINE DCHKTSQR( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
+ SUBROUTINE DCHKTSQR( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
$ NBVAL, NOUT )
IMPLICIT NONE
*
DOUBLE PRECISION RESULT( NTESTS )
* ..
* .. External Subroutines ..
- EXTERNAL ALAERH, ALAHD, ALASUM, DERRTSQR,
+ EXTERNAL ALAERH, ALAHD, ALASUM, DERRTSQR,
$ DTSQR01, XLAENV
* ..
* .. Intrinsic Functions ..
- INTRINSIC MAX, MIN
+ INTRINSIC MAX, MIN
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
DO J = 1, NN
N = NVAL( J )
IF (MIN(M,N).NE.0) THEN
- DO INB = 1, NNB
+ DO INB = 1, NNB
MB = NBVAL( INB )
CALL XLAENV( 1, MB )
DO IMB = 1, NNB
CALL XLAENV( 2, NB )
*
* Test DGEQR and DGEMQR
-*
+*
CALL DTSQR01( 'TS', M, N, MB, NB, RESULT )
*
* Print information about the tests that did not
END IF
END DO
NRUN = NRUN + NTESTS
- END DO
- END DO
- END IF
+ END DO
+ END DO
+ END IF
END DO
END DO
*
DO J = 1, NN
N = NVAL( J )
IF (MIN(M,N).NE.0) THEN
- DO INB = 1, NNB
+ DO INB = 1, NNB
MB = NBVAL( INB )
CALL XLAENV( 1, MB )
DO IMB = 1, NNB
CALL XLAENV( 2, NB )
*
* Test DGEQR and DGEMQR
-*
+*
CALL DTSQR01( 'SW', M, N, MB, NB, RESULT )
*
* Print information about the tests that did not
END IF
END DO
NRUN = NRUN + NTESTS
- END DO
- END DO
- END IF
+ END DO
+ END DO
+ END IF
END DO
END DO
*
*
* End of DCHKQRT
*
- END
\ No newline at end of file
+ END
* .. Local Scalars ..
CHARACTER TRANS
CHARACTER*3 PATH
- INTEGER CRANK, I, IM, IMB, IN, INB, INFO, INS, IRANK,
- $ ISCALE, ITRAN, ITYPE, J, K, LDA, LDB, LDWORK,
- $ LWLSY, LWORK, M, MNMIN, N, NB, NCOLS, NERRS,
+ INTEGER CRANK, I, IM, IMB, IN, INB, INFO, INS, IRANK,
+ $ ISCALE, ITRAN, ITYPE, J, K, LDA, LDB, LDWORK,
+ $ LWLSY, LWORK, M, MNMIN, N, NB, NCOLS, NERRS,
$ NFAIL, NLVL, NRHS, NROWS, NRUN, RANK, MB, LWTS
DOUBLE PRECISION EPS, NORMA, NORMB, RCOND
* ..
LWORK = MAX( 1, ( M+NRHS )*( N+2 ), ( N+NRHS )*( M+2 ),
$ M*N+4*MNMIN+MAX( M, N ), 12*MNMIN+2*MNMIN*SMLSIZ+
$ 8*MNMIN*NLVL+MNMIN*NRHS+(SMLSIZ+1)**2,LWTS)
- $
+ $
*
DO 120 IRANK = 1, 2
DO 110 ISCALE = 1, 3
$ COPYB, LDB, B, LDB )
END IF
SRNAMT = 'DGETSLS '
- CALL DGETSLS( TRANS, M, N, NRHS, A,
+ CALL DGETSLS( TRANS, M, N, NRHS, A,
$ LDA, B, LDB, WORK, LWORK, INFO )
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'DGETSLS ', INFO, 0,
$ ', NB=', I4, ', type', I2, ', test(', I2, ')=', G12.5 )
9998 FORMAT( ' M=', I5, ', N=', I5, ', NRHS=', I4, ', NB=', I4,
$ ', type', I2, ', test(', I2, ')=', G12.5 )
- 9997 FORMAT( ' TRANS=''', A1,' M=', I5, ', N=', I5, ', NRHS=', I4,
- $ ', MB=', I4,', NB=', I4,', type', I2,
+ 9997 FORMAT( ' TRANS=''', A1,' M=', I5, ', N=', I5, ', NRHS=', I4,
+ $ ', MB=', I4,', NB=', I4,', type', I2,
$ ', test(', I2, ')=', G12.5 )
RETURN
*
* residual.
*
CALL DSYT01_AASEN( UPLO, N, A, LDA, AFAC, LDA,
- $ IWORK, AINV, LDA, RWORK,
+ $ IWORK, AINV, LDA, RWORK,
$ RESULT( 1 ) )
*
* Compute residual of the computed solution.
*
* =========== DOCUMENTATION ===========
*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE DERRLQT( PATH, NUNIT )
-*
+*
* .. Scalar Arguments ..
* CHARACTER*3 PATH
* INTEGER NUNIT
* ..
-*
+*
*
*> \par Purpose:
* =============
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
*> \date November 2011
*
* ..
* .. External Subroutines ..
EXTERNAL ALAESM, CHKXER, DGELQT3, DGELQT,
- $ DGEMLQT
+ $ DGEMLQT
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
*
* =========== DOCUMENTATION ===========
*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE DERRLQTP( PATH, NUNIT )
-*
+*
* .. Scalar Arguments ..
* CHARACTER*3 PATH
* INTEGER NUNIT
* ..
-*
+*
*
*> \par Purpose:
* =============
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
*> \date November 2011
*
* ..
* .. External Subroutines ..
EXTERNAL ALAESM, CHKXER, DTPLQT2, DTPLQT,
- $ DTPMLQT
+ $ DTPMLQT
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
*
SRNAMT = 'DTPMLQT'
INFOT = 1
- CALL DTPMLQT( '/', 'N', 0, 0, 0, 0, 1, A, 1, T, 1, B, 1, C, 1,
+ CALL DTPMLQT( '/', 'N', 0, 0, 0, 0, 1, A, 1, T, 1, B, 1, C, 1,
$ W, INFO )
CALL CHKXER( 'DTPMLQT', INFOT, NOUT, LERR, OK )
INFOT = 2
- CALL DTPMLQT( 'L', '/', 0, 0, 0, 0, 1, A, 1, T, 1, B, 1, C, 1,
+ CALL DTPMLQT( 'L', '/', 0, 0, 0, 0, 1, A, 1, T, 1, B, 1, C, 1,
$ W, INFO )
CALL CHKXER( 'DTPMLQT', INFOT, NOUT, LERR, OK )
INFOT = 3
- CALL DTPMLQT( 'L', 'N', -1, 0, 0, 0, 1, A, 1, T, 1, B, 1, C, 1,
+ CALL DTPMLQT( 'L', 'N', -1, 0, 0, 0, 1, A, 1, T, 1, B, 1, C, 1,
$ W, INFO )
CALL CHKXER( 'DTPMLQT', INFOT, NOUT, LERR, OK )
INFOT = 4
- CALL DTPMLQT( 'L', 'N', 0, -1, 0, 0, 1, A, 1, T, 1, B, 1, C, 1,
+ CALL DTPMLQT( 'L', 'N', 0, -1, 0, 0, 1, A, 1, T, 1, B, 1, C, 1,
$ W, INFO )
CALL CHKXER( 'DTPMLQT', INFOT, NOUT, LERR, OK )
INFOT = 5
- CALL DTPMLQT( 'L', 'N', 0, 0, -1, 0, 1, A, 1, T, 1, B, 1, C, 1,
+ CALL DTPMLQT( 'L', 'N', 0, 0, -1, 0, 1, A, 1, T, 1, B, 1, C, 1,
$ W, INFO )
INFOT = 6
- CALL DTPMLQT( 'L', 'N', 0, 0, 0, -1, 1, A, 1, T, 1, B, 1, C, 1,
+ CALL DTPMLQT( 'L', 'N', 0, 0, 0, -1, 1, A, 1, T, 1, B, 1, C, 1,
$ W, INFO )
CALL CHKXER( 'DTPMLQT', INFOT, NOUT, LERR, OK )
INFOT = 7
- CALL DTPMLQT( 'L', 'N', 0, 0, 0, 0, 0, A, 1, T, 1, B, 1, C, 1,
+ CALL DTPMLQT( 'L', 'N', 0, 0, 0, 0, 0, A, 1, T, 1, B, 1, C, 1,
$ W, INFO )
CALL CHKXER( 'DTPMLQT', INFOT, NOUT, LERR, OK )
INFOT = 9
- CALL DTPMLQT( 'R', 'N', 2, 2, 2, 1, 1, A, 1, T, 1, B, 1, C, 1,
+ CALL DTPMLQT( 'R', 'N', 2, 2, 2, 1, 1, A, 1, T, 1, B, 1, C, 1,
$ W, INFO )
CALL CHKXER( 'DTPMLQT', INFOT, NOUT, LERR, OK )
INFOT = 11
- CALL DTPMLQT( 'R', 'N', 1, 1, 1, 1, 1, A, 1, T, 0, B, 1, C, 1,
+ CALL DTPMLQT( 'R', 'N', 1, 1, 1, 1, 1, A, 1, T, 0, B, 1, C, 1,
$ W, INFO )
CALL CHKXER( 'DTPMLQT', INFOT, NOUT, LERR, OK )
INFOT = 13
- CALL DTPMLQT( 'L', 'N', 1, 1, 1, 1, 1, A, 1, T, 1, B, 0, C, 1,
+ CALL DTPMLQT( 'L', 'N', 1, 1, 1, 1, 1, A, 1, T, 1, B, 0, C, 1,
$ W, INFO )
CALL CHKXER( 'DTPMLQT', INFOT, NOUT, LERR, OK )
INFOT = 15
- CALL DTPMLQT( 'L', 'N', 1, 1, 1, 1, 1, A, 1, T, 1, B, 1, C, 0,
+ CALL DTPMLQT( 'L', 'N', 1, 1, 1, 1, 1, A, 1, T, 1, B, 1, C, 0,
$ W, INFO )
CALL CHKXER( 'DTPMLQT', INFOT, NOUT, LERR, OK )
*
*
* =========== DOCUMENTATION ===========
*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE DERRTSQR( PATH, NUNIT )
-*
+*
* .. Scalar Arguments ..
* CHARACTER*3 PATH
* INTEGER NUNIT
* ..
-*
+*
*
*> \par Purpose:
* =============
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
*> \date November 2011
*
*
* =========== DOCUMENTATION ===========
*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE DLQT04(M,N,NB,RESULT)
-*
+*
* .. Scalar Arguments ..
* INTEGER M, N, NB, LDT
* .. Return values ..
* DOUBLE PRECISION RESULT(6)
-*
+*
*
*> \par Purpose:
* =============
*> RESULT(2) = | I - Q Q^H |
*> RESULT(3) = | Q C - Q C |
*> RESULT(4) = | Q^H C - Q^H C |
-*> RESULT(5) = | C Q - C Q |
+*> RESULT(5) = | C Q - C Q |
*> RESULT(6) = | C Q^H - C Q^H |
*> \endverbatim
*
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
*> \date April 2012
*
* =====================================================================
*
* ..
-* .. Local allocatable arrays
+* .. Local allocatable arrays
DOUBLE PRECISION, ALLOCATABLE :: AF(:,:), Q(:,:),
- $ L(:,:), RWORK(:), WORK( : ), T(:,:),
+ $ L(:,:), RWORK(:), WORK( : ), T(:,:),
$ CF(:,:), DF(:,:), A(:,:), C(:,:), D(:,:)
*
* .. Parameters ..
EXTERNAL DLAMCH, DLANGE, DLANSY, LSAME
* ..
* .. Intrinsic Functions ..
- INTRINSIC MAX, MIN
+ INTRINSIC MAX, MIN
* ..
* .. Data statements ..
- DATA ISEED / 1988, 1989, 1990, 1991 /
-*
+ DATA ISEED / 1988, 1989, 1990, 1991 /
+*
EPS = DLAMCH( 'Epsilon' )
K = MIN(M,N)
LL = MAX(M,N)
*
* Dynamically allocate local arrays
*
- ALLOCATE ( A(M,N), AF(M,N), Q(N,N), L(LL,N), RWORK(LL),
- $ WORK(LWORK), T(NB,N), C(M,N), CF(M,N),
+ ALLOCATE ( A(M,N), AF(M,N), Q(N,N), L(LL,N), RWORK(LL),
+ $ WORK(LWORK), T(NB,N), C(M,N), CF(M,N),
$ D(N,M), DF(N,M) )
*
* Put random numbers into A and copy to AF
* Generate the n-by-n matrix Q
*
CALL DLASET( 'Full', N, N, ZERO, ONE, Q, N )
- CALL DGEMLQT( 'R', 'N', N, N, K, NB, AF, M, T, LDT, Q, N,
+ CALL DGEMLQT( 'R', 'N', N, N, K, NB, AF, M, T, LDT, Q, N,
$ WORK, INFO )
*
* Copy R
*
* Apply Q to C as Q*C
*
- CALL DGEMLQT( 'L', 'N', N, M, K, NB, AF, M, T, NB, DF, N,
+ CALL DGEMLQT( 'L', 'N', N, M, K, NB, AF, M, T, NB, DF, N,
$ WORK, INFO)
*
* Compute |Q*D - Q*D| / |D|
*
* Apply Q to D as QT*D
*
- CALL DGEMLQT( 'L', 'T', N, M, K, NB, AF, M, T, NB, DF, N,
+ CALL DGEMLQT( 'L', 'T', N, M, K, NB, AF, M, T, NB, DF, N,
$ WORK, INFO)
*
* Compute |QT*D - QT*D| / |D|
RESULT( 4 ) = RESID / (EPS*MAX(1,M)*DNORM)
ELSE
RESULT( 4 ) = ZERO
- END IF
+ END IF
*
* Generate random n-by-m matrix D and a copy DF
*
*
* Apply Q to C as C*Q
*
- CALL DGEMLQT( 'R', 'N', M, N, K, NB, AF, M, T, NB, CF, M,
- $ WORK, INFO)
+ CALL DGEMLQT( 'R', 'N', M, N, K, NB, AF, M, T, NB, CF, M,
+ $ WORK, INFO)
*
* Compute |C*Q - C*Q| / |C|
*
*
* Apply Q to D as D*QT
*
- CALL DGEMLQT( 'R', 'T', M, N, K, NB, AF, M, T, NB, CF, M,
- $ WORK, INFO)
+ CALL DGEMLQT( 'R', 'T', M, N, K, NB, AF, M, T, NB, CF, M,
+ $ WORK, INFO)
*
* Compute |C*QT - C*QT| / |C|
*
*
* =========== DOCUMENTATION ===========
*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE DLQT05(M,N,L,NB,RESULT)
-*
+*
* .. Scalar Arguments ..
* INTEGER LWORK, M, N, L, NB, LDT
* .. Return values ..
* DOUBLE PRECISION RESULT(6)
-*
+*
*
*> \par Purpose:
* =============
*> The number of rows of the upper trapezoidal part the
*> lower test matrix. 0 <= L <= M.
*> \endverbatim
-*>
+*>
*> \param[in] NB
*> \verbatim
*> NB is INTEGER
*> RESULT(2) = | I - Q^H Q |
*> RESULT(3) = | Q C - Q C |
*> RESULT(4) = | Q^H C - Q^H C |
-*> RESULT(5) = | C Q - C Q |
+*> RESULT(5) = | C Q - C Q |
*> RESULT(6) = | C Q^H - C Q^H |
*> \endverbatim
*
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
*> \date April 2012
*
DOUBLE PRECISION RESULT(6)
*
* =====================================================================
-*
+*
* ..
-* .. Local allocatable arrays
+* .. Local allocatable arrays
DOUBLE PRECISION, ALLOCATABLE :: AF(:,:), Q(:,:),
- $ R(:,:), RWORK(:), WORK( : ), T(:,:),
+ $ R(:,:), RWORK(:), WORK( : ), T(:,:),
$ CF(:,:), DF(:,:), A(:,:), C(:,:), D(:,:)
*
* .. Parameters ..
* ..
* .. Data statements ..
DATA ISEED / 1988, 1989, 1990, 1991 /
-*
+*
EPS = DLAMCH( 'Epsilon' )
K = M
N2 = M+N
* Dynamically allocate all arrays
*
ALLOCATE(A(M,N2),AF(M,N2),Q(N2,N2),R(N2,N2),RWORK(N2),
- $ WORK(LWORK),T(NB,M),C(N2,M),CF(N2,M),
+ $ WORK(LWORK),T(NB,M),C(N2,M),CF(N2,M),
$ D(M,N2),DF(M,N2) )
*
* Put random stuff into A
END IF
IF( L.GT.0 ) THEN
DO J=1,L
- CALL DLARNV( 2, ISEED, M-J+1, A( J, MIN(N+M,N+M-L+1)
+ CALL DLARNV( 2, ISEED, M-J+1, A( J, MIN(N+M,N+M-L+1)
$ + J - 1 ) )
END DO
END IF
CALL DLACPY( 'Full', N2, M, C, N2, CF, N2 )
*
* Apply Q to C as Q*C
-*
+*
CALL DTPMLQT( 'L','N', N,M,K,L,NB,AF(1, NP1),M,T,LDT,CF,N2,
$ CF(NP1,1),N2,WORK,INFO)
*
* Apply Q to C as QT*C
*
CALL DTPMLQT( 'L','T',N,M,K,L,NB,AF(1,NP1),M,T,LDT,CF,N2,
- $ CF(NP1,1),N2,WORK,INFO)
+ $ CF(NP1,1),N2,WORK,INFO)
*
* Compute |QT*C - QT*C| / |C|
*
CALL DGEMM('T','N',N2,M,N2,-ONE,Q,N2,C,N2,ONE,CF,N2)
RESID = DLANGE( '1', N2, M, CF, N2, RWORK )
-
+
IF( CNORM.GT.ZERO ) THEN
RESULT( 4 ) = RESID / (EPS*MAX(1,N2)*CNORM)
ELSE
RESULT( 4 ) = ZERO
- END IF
+ END IF
*
* Generate random m-by-n matrix D and a copy DF
*
* Apply Q to D as D*QT
*
CALL DTPMLQT('R','T',M,N,K,L,NB,AF(1,NP1),M,T,LDT,DF,M,
- $ DF(1,NP1),M,WORK,INFO)
-
+ $ DF(1,NP1),M,WORK,INFO)
+
*
* Compute |D*QT - D*QT| / |D|
*
*
DEALLOCATE ( A, AF, Q, R, RWORK, WORK, T, C, D, CF, DF)
RETURN
- END
\ No newline at end of file
+ END
*
* =========== DOCUMENTATION ===========
*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
-*> Download DTPQRT + dependencies
-*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dtplqt.f">
-*> [TGZ]</a>
-*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dtplqt.f">
-*> [ZIP]</a>
-*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dtplqt.f">
+*> Download DTPQRT + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dtplqt.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dtplqt.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dtplqt.f">
*> [TXT]</a>
-*> \endhtmlonly
+*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DTPLQT( M, N, L, MB, A, LDA, B, LDB, T, LDT, WORK,
* INFO )
-*
+*
* .. Scalar Arguments ..
* INTEGER INFO, LDA, LDB, LDT, N, M, L, MB
* ..
* .. Array Arguments ..
* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), T( LDT, * ), WORK( * )
* ..
-*
+*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
-*> DTPLQT computes a blocked LQ factorization of a real
-*> "triangular-pentagonal" matrix C, which is composed of a
-*> triangular block A and pentagonal block B, using the compact
+*> DTPLQT computes a blocked LQ factorization of a real
+*> "triangular-pentagonal" matrix C, which is composed of a
+*> triangular block A and pentagonal block B, using the compact
*> WY representation for Q.
*> \endverbatim
*
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix B, and the order of the
-*> triangular matrix A.
+*> triangular matrix A.
*> M >= 0.
*> \endverbatim
*>
*> \param[in,out] B
*> \verbatim
*> B is DOUBLE PRECISION array, dimension (LDB,N)
-*> On entry, the pentagonal M-by-N matrix B. The first N-L columns
+*> On entry, the pentagonal M-by-N matrix B. The first N-L columns
*> are rectangular, and the last L columns are lower trapezoidal.
*> On exit, B contains the pentagonal matrix V. See Further Details.
*> \endverbatim
*> The lower triangular block reflectors stored in compact form
*> as a sequence of upper triangular blocks. See Further Details.
*> \endverbatim
-*>
+*>
*> \param[in] LDT
*> \verbatim
*> LDT is INTEGER
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
*> \date November 2013
*
*>
*> \verbatim
*>
-*> The input matrix C is a M-by-(M+N) matrix
+*> The input matrix C is a M-by-(M+N) matrix
*>
*> C = [ A ] [ B ]
-*>
+*>
*>
*> where A is an lower triangular N-by-N matrix, and B is M-by-N pentagonal
*> matrix consisting of a M-by-(N-L) rectangular matrix B1 on left of a M-by-L
*> upper trapezoidal matrix B2:
-*> [ B ] = [ B1 ] [ B2 ]
+*> [ B ] = [ B1 ] [ B2 ]
*> [ B1 ] <- M-by-(N-L) rectangular
*> [ B2 ] <- M-by-L upper trapezoidal.
*>
*> The lower trapezoidal matrix B2 consists of the first L columns of a
-*> N-by-N lower triangular matrix, where 0 <= L <= MIN(M,N). If L=0,
-*> B is rectangular M-by-N; if M=L=N, B is lower triangular.
+*> N-by-N lower triangular matrix, where 0 <= L <= MIN(M,N). If L=0,
+*> B is rectangular M-by-N; if M=L=N, B is lower triangular.
*>
*> The matrix W stores the elementary reflectors H(i) in the i-th row
*> above the diagonal (of A) in the M-by-(M+N) input matrix C
-*> [ C ] = [ A ] [ B ]
+*> [ C ] = [ A ] [ B ]
*> [ A ] <- lower triangular N-by-N
*> [ B ] <- M-by-N pentagonal
*>
*> so that W can be represented as
-*> [ W ] = [ I ] [ V ]
+*> [ W ] = [ I ] [ V ]
*> [ I ] <- identity, N-by-N
*> [ V ] <- M-by-N, same form as B.
*>
*> Thus, all of information needed for W is contained on exit in B, which
-*> we call V above. Note that V has the same form as B; that is,
-*> [ V ] = [ V1 ] [ V2 ]
+*> we call V above. Note that V has the same form as B; that is,
+*> [ V ] = [ V1 ] [ V2 ]
*> [ V1 ] <- M-by-(N-L) rectangular
*> [ V2 ] <- M-by-L lower trapezoidal.
*>
-*> The rows of V represent the vectors which define the H(i)'s.
+*> The rows of V represent the vectors which define the H(i)'s.
*>
*> The number of blocks is B = ceiling(M/MB), where each
-*> block is of order MB except for the last block, which is of order
+*> block is of order MB except for the last block, which is of order
*> IB = M - (M-1)*MB. For each of the B blocks, a upper triangular block
-*> reflector factor is computed: T1, T2, ..., TB. The MB-by-MB (and IB-by-IB
+*> reflector factor is computed: T1, T2, ..., TB. The MB-by-MB (and IB-by-IB
*> for the last block) T's are stored in the MB-by-N matrix T as
*>
*> T = [T1 T2 ... TB].
IF( M.EQ.0 .OR. N.EQ.0 ) RETURN
*
DO I = 1, M, MB
-*
+*
* Compute the QR factorization of the current block
*
IB = MIN( M-I+1, MB )
LB = NB-N+L-I+1
END IF
*
- CALL DTPLQT2( IB, NB, LB, A(I,I), LDA, B( I, 1 ), LDB,
+ CALL DTPLQT2( IB, NB, LB, A(I,I), LDA, B( I, 1 ), LDB,
$ T(1, I ), LDT, IINFO )
*
* Update by applying H**T to B(I+IB:M,:) from the right
*
IF( I+IB.LE.M ) THEN
CALL DTPRFB( 'R', 'N', 'F', 'R', M-I-IB+1, NB, IB, LB,
- $ B( I, 1 ), LDB, T( 1, I ), LDT,
- $ A( I+IB, I ), LDA, B( I+IB, 1 ), LDB,
+ $ B( I, 1 ), LDB, T( 1, I ), LDT,
+ $ A( I+IB, I ), LDA, B( I+IB, 1 ), LDB,
$ WORK, M-I-IB+1)
END IF
END DO
RETURN
-*
+*
* End of DTPLQT
*
END
*
* =========== DOCUMENTATION ===========
*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE DTSQR01(TSSW, M,N, MB, NB, RESULT)
-*
+*
* .. Scalar Arguments ..
* INTEGER M, N, MB
* .. Return values ..
* DOUBLE PRECISION RESULT(6)
-*
+*
*
*> \par Purpose:
* =============
*> RESULT(2) = | I - Q^H Q | or | I - Q Q^H |
*> RESULT(3) = | Q C - Q C |
*> RESULT(4) = | Q^H C - Q^H C |
-*> RESULT(5) = | C Q - C Q |
+*> RESULT(5) = | C Q - C Q |
*> RESULT(6) = | C Q^H - C Q^H |
*> \endverbatim
*
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
*> \date April 2012
*
* =====================================================================
*
* ..
-* .. Local allocatable arrays
+* .. Local allocatable arrays
DOUBLE PRECISION, ALLOCATABLE :: AF(:,:), Q(:,:),
- $ R(:,:), RWORK(:), WORK( : ), T(:),
+ $ R(:,:), RWORK(:), WORK( : ), T(:),
$ CF(:,:), DF(:,:), A(:,:), C(:,:), D(:,:), LQ(:,:)
*
* .. Parameters ..
EXTERNAL DLAMCH, DLANGE, DLANSY, LSAME, ILAENV
* ..
* .. Intrinsic Functions ..
- INTRINSIC MAX, MIN
+ INTRINSIC MAX, MIN
* .. Scalars in Common ..
CHARACTER*32 srnamt
* ..
* .. Common blocks ..
- COMMON / srnamc / srnamt
+ COMMON / srnamc / srnamt
* ..
* .. Data statements ..
- DATA ISEED / 1988, 1989, 1990, 1991 /
+ DATA ISEED / 1988, 1989, 1990, 1991 /
*
* TEST TALL SKINNY OR SHORT WIDE
*
TS = LSAME(TSSW, 'TS')
-*
+*
* TEST MATRICES WITH HALF OF MATRIX BEING ZEROS
*
TESTZEROS = .FALSE.
-*
+*
EPS = DLAMCH( 'Epsilon' )
K = MIN(M,N)
L = MAX(M,N,1)
IF((K.GE.MNB).OR.(MNB.GE.L))THEN
LT=MAX(1,L)*MNB+5
ELSE
- LT=MAX(1,(L-K)/(MNB-K)+1)*L*MNB+5
+ LT=MAX(1,(L-K)/(MNB-K)+1)*L*MNB+5
END IF
*
* Dynamically allocate local arrays
*
- ALLOCATE ( A(M,N), AF(M,N), Q(L,L), R(M,L), RWORK(L),
- $ WORK(LWORK), T(LT), C(M,N), CF(M,N),
+ ALLOCATE ( A(M,N), AF(M,N), Q(L,L), R(M,L), RWORK(L),
+ $ WORK(LWORK), T(LT), C(M,N), CF(M,N),
$ D(N,M), DF(N,M), LQ(L,N) )
*
* Put random numbers into A and copy to AF
*
CALL DLASET( 'Full', M, M, ZERO, ONE, Q, M )
srnamt = 'DGEMQR'
- CALL DGEMQR( 'L', 'N', M, M, K, AF, M, T, LT, Q, M,
+ CALL DGEMQR( 'L', 'N', M, M, K, AF, M, T, LT, Q, M,
$ WORK, LWORK, INFO )
*
* Copy R
* Apply Q to C as Q*C
*
srnamt = 'DGEMQR'
- CALL DGEMQR( 'L', 'N', M, N, K, AF, M, T, LT, CF, M,
+ CALL DGEMQR( 'L', 'N', M, N, K, AF, M, T, LT, CF, M,
$ WORK, LWORK, INFO)
*
* Compute |Q*C - Q*C| / |C|
* Apply Q to C as QT*C
*
srnamt = 'DGEMQR'
- CALL DGEMQR( 'L', 'T', M, N, K, AF, M, T, LT, CF, M,
+ CALL DGEMQR( 'L', 'T', M, N, K, AF, M, T, LT, CF, M,
$ WORK, LWORK, INFO)
*
* Compute |QT*C - QT*C| / |C|
RESULT( 4 ) = RESID / (EPS*MAX(1,M)*CNORM)
ELSE
RESULT( 4 ) = ZERO
- END IF
+ END IF
*
* Generate random n-by-m matrix D and a copy DF
*
* Apply Q to D as D*Q
*
srnamt = 'DGEMQR'
- CALL DGEMQR( 'R', 'N', N, M, K, AF, M, T, LT, DF, N,
- $ WORK, LWORK, INFO)
+ CALL DGEMQR( 'R', 'N', N, M, K, AF, M, T, LT, DF, N,
+ $ WORK, LWORK, INFO)
*
* Compute |D*Q - D*Q| / |D|
*
*
* Apply Q to D as D*QT
*
- CALL DGEMQR( 'R', 'T', N, M, K, AF, M, T, LT, DF, N,
- $ WORK, LWORK, INFO)
+ CALL DGEMQR( 'R', 'T', N, M, K, AF, M, T, LT, DF, N,
+ $ WORK, LWORK, INFO)
*
* Compute |D*QT - D*QT| / |D|
*
*
CALL DLASET( 'Full', N, N, ZERO, ONE, Q, N )
srnamt = 'DGEMLQ'
- CALL DGEMLQ( 'R', 'N', N, N, K, AF, M, T, LT, Q, N,
+ CALL DGEMLQ( 'R', 'N', N, N, K, AF, M, T, LT, Q, N,
$ WORK, LWORK, INFO )
*
* Copy R
*
* Apply Q to C as Q*C
*
- CALL DGEMLQ( 'L', 'N', N, M, K, AF, M, T, LT, DF, N,
+ CALL DGEMLQ( 'L', 'N', N, M, K, AF, M, T, LT, DF, N,
$ WORK, LWORK, INFO)
*
* Compute |Q*D - Q*D| / |D|
*
* Apply Q to D as QT*D
*
- CALL DGEMLQ( 'L', 'T', N, M, K, AF, M, T, LT, DF, N,
+ CALL DGEMLQ( 'L', 'T', N, M, K, AF, M, T, LT, DF, N,
$ WORK, LWORK, INFO)
*
* Compute |QT*D - QT*D| / |D|
RESULT( 4 ) = RESID / (EPS*MAX(1,N)*DNORM)
ELSE
RESULT( 4 ) = ZERO
- END IF
+ END IF
*
* Generate random n-by-m matrix D and a copy DF
*
*
* Apply Q to C as C*Q
*
- CALL DGEMLQ( 'R', 'N', M, N, K, AF, M, T, LT, CF, M,
- $ WORK, LWORK, INFO)
+ CALL DGEMLQ( 'R', 'N', M, N, K, AF, M, T, LT, CF, M,
+ $ WORK, LWORK, INFO)
*
* Compute |C*Q - C*Q| / |C|
*
*
* Apply Q to D as D*QT
*
- CALL DGEMLQ( 'R', 'T', M, N, K, AF, M, T, LT, CF, M,
- $ WORK, LWORK, INFO)
+ CALL DGEMLQ( 'R', 'T', M, N, K, AF, M, T, LT, CF, M,
+ $ WORK, LWORK, INFO)
*
* Compute |C*QT - C*QT| / |C|
*
DEALLOCATE ( A, AF, Q, R, RWORK, WORK, T, C, D, CF, DF)
*
RETURN
- END
\ No newline at end of file
+ END
* QX: QRT routines for triangular-pentagonal matrices
*
IF( TSTCHK ) THEN
- CALL SCHKQRTP( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
+ CALL SCHKQRTP( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
$ NBVAL, NOUT )
ELSE
WRITE( NOUT, FMT = 9989 )PATH
* TQ: LQT routines for general matrices
*
IF( TSTCHK ) THEN
- CALL SCHKLQT( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
+ CALL SCHKLQT( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
$ NBVAL, NOUT )
ELSE
WRITE( NOUT, FMT = 9989 )PATH
* XQ: LQT routines for triangular-pentagonal matrices
*
IF( TSTCHK ) THEN
- CALL SCHKLQTP( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
+ CALL SCHKLQTP( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
$ NBVAL, NOUT )
ELSE
WRITE( NOUT, FMT = 9989 )PATH
* TS: QR routines for tall-skinny matrices
*
IF( TSTCHK ) THEN
- CALL SCHKTSQR( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
+ CALL SCHKTSQR( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
$ NBVAL, NOUT )
ELSE
WRITE( NOUT, FMT = 9989 )PATH
*
* =========== DOCUMENTATION ===========
*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
-* SUBROUTINE SCHKLQT( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
+* SUBROUTINE SCHKLQT( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
* NBVAL, NOUT )
-*
+*
* .. Scalar Arguments ..
* LOGICAL TSTERR
* INTEGER NM, NN, NNB, NOUT
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup double_lin
*
* =====================================================================
- SUBROUTINE SCHKLQT( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
+ SUBROUTINE SCHKLQT( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
$ NBVAL, NOUT )
IMPLICIT NONE
*
NB = NBVAL( K )
*
* Test DGELQT and DGEMLQT
-*
+*
IF( (NB.LE.MINMN).AND.(NB.GT.0) ) THEN
CALL SLQT04( M, N, NB, RESULT )
*
*
* =========== DOCUMENTATION ===========
*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
-* SUBROUTINE SCHKLQTP( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
+* SUBROUTINE SCHKLQTP( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
* NBVAL, NOUT )
*
* .. Scalar Arguments ..
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup double_lin
*
* =====================================================================
- SUBROUTINE SCHKLQTP( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
+ SUBROUTINE SCHKLQTP( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
$ NBVAL, NOUT )
IMPLICIT NONE
*
*
MINMN = MIN( M, N )
DO L = 0, MINMN, MAX( MINMN, 1 )
-*
+*
* Do for each possible value of NB
*
DO K = 1, NNB
NB = NBVAL( K )
*
* Test DTPLQT and DTPMLQT
-*
+*
IF( (NB.LE.M).AND.(NB.GT.0) ) THEN
CALL SLQT05( M, N, L, NB, RESULT )
*
*
SRNAMT = 'SSYTRF_AASEN'
LWORK = N*NB + N
- CALL SSYTRF_AASEN( UPLO, N, AFAC, LDA, IWORK, AINV,
+ CALL SSYTRF_AASEN( UPLO, N, AFAC, LDA, IWORK, AINV,
$ LWORK, INFO )
*
* Adjust the expected value of INFO to account for
* Check error code from SSYTRF and handle error.
*
IF( INFO.NE.K ) THEN
- CALL ALAERH( PATH, 'SSYTRF_AASEN', INFO, K, UPLO,
- $ N, N, -1, -1, NB, IMAT, NFAIL, NERRS,
+ CALL ALAERH( PATH, 'SSYTRF_AASEN', INFO, K, UPLO,
+ $ N, N, -1, -1, NB, IMAT, NFAIL, NERRS,
$ NOUT )
END IF
*
*
SRNAMT = 'SSYTRS_AASEN'
LWORK = 3*N-2
- CALL SSYTRS_AASEN( UPLO, N, NRHS, AFAC, LDA,
+ CALL SSYTRS_AASEN( UPLO, N, NRHS, AFAC, LDA,
$ IWORK, X, LDA, WORK, LWORK,
$ INFO )
*
*
IF( INFO.NE.0 ) THEN
CALL ALAERH( PATH, 'SSYTRS_AASEN', INFO, 0,
- $ UPLO, N, N, -1, -1, NRHS, IMAT,
+ $ UPLO, N, N, -1, -1, NRHS, IMAT,
$ NFAIL, NERRS, NOUT )
END IF
*
*
* =========== DOCUMENTATION ===========
*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
-* SUBROUTINE SCHKTSQR( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
+* SUBROUTINE SCHKTSQR( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
* NBVAL, NOUT )
-*
+*
* .. Scalar Arguments ..
* LOGICAL TSTERR
* INTEGER NM, NN, NNB, NOUT
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup double_lin
*
* =====================================================================
- SUBROUTINE SCHKTSQR( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
+ SUBROUTINE SCHKTSQR( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
$ NBVAL, NOUT )
IMPLICIT NONE
*
REAL RESULT( NTESTS )
* ..
* .. External Subroutines ..
- EXTERNAL ALAERH, ALAHD, ALASUM, SERRTSQR,
+ EXTERNAL ALAERH, ALAHD, ALASUM, SERRTSQR,
$ STSQR01, XLAENV
* ..
* .. Intrinsic Functions ..
- INTRINSIC MAX, MIN
+ INTRINSIC MAX, MIN
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
DO J = 1, NN
N = NVAL( J )
IF (MIN(M,N).NE.0) THEN
- DO INB = 1, NNB
+ DO INB = 1, NNB
MB = NBVAL( INB )
CALL XLAENV( 1, MB )
DO IMB = 1, NNB
CALL XLAENV( 2, NB )
*
* Test SGEQR and SGEMQR
-*
+*
CALL STSQR01('TS', M, N, MB, NB, RESULT )
*
* Print information about the tests that did not
END DO
NRUN = NRUN + NTESTS
END DO
- END DO
+ END DO
END IF
END DO
END DO
DO J = 1, NN
N = NVAL( J )
IF (MIN(M,N).NE.0) THEN
- DO INB = 1, NNB
+ DO INB = 1, NNB
MB = NBVAL( INB )
CALL XLAENV( 1, MB )
DO IMB = 1, NNB
CALL XLAENV( 2, NB )
*
* Test SGEQR and SGEMQR
-*
+*
CALL STSQR01('SW', M, N, MB, NB, RESULT )
*
* Print information about the tests that did not
END IF
END DO
NRUN = NRUN + NTESTS
- END DO
- END DO
- END IF
+ END DO
+ END DO
+ END IF
END DO
END DO
*
* .. Local Scalars ..
CHARACTER TRANS
CHARACTER*3 PATH
- INTEGER CRANK, I, IM, IMB, IN, INB, INFO, INS, IRANK,
- $ ISCALE, ITRAN, ITYPE, J, K, LDA, LDB, LDWORK,
- $ LWLSY, LWORK, M, MNMIN, N, NB, NCOLS, NERRS,
+ INTEGER CRANK, I, IM, IMB, IN, INB, INFO, INS, IRANK,
+ $ ISCALE, ITRAN, ITYPE, J, K, LDA, LDB, LDWORK,
+ $ LWLSY, LWORK, M, MNMIN, N, NB, NCOLS, NERRS,
$ NFAIL, NLVL, NRHS, NROWS, NRUN, RANK, MB, LWTS
REAL EPS, NORMA, NORMB, RCOND
* ..
LWORK = MAX( 1, ( M+NRHS )*( N+2 ), ( N+NRHS )*( M+2 ),
$ M*N+4*MNMIN+MAX( M, N ), 12*MNMIN+2*MNMIN*SMLSIZ+
$ 8*MNMIN*NLVL+MNMIN*NRHS+(SMLSIZ+1)**2,LWTS)
- $
+ $
*
DO 120 IRANK = 1, 2
DO 110 ISCALE = 1, 3
CALL XLAENV( 1, MB )
DO 62 IMB = 1, NNB
NB = NBVAL( IMB )
- CALL XLAENV( 2, NB )
+ CALL XLAENV( 2, NB )
*
DO 60 ITRAN = 1, 2
IF( ITRAN.EQ.1 ) THEN
$ COPYB, LDB, B, LDB )
END IF
SRNAMT = 'SGETSLS '
- CALL SGETSLS( TRANS, M, N, NRHS, A,
+ CALL SGETSLS( TRANS, M, N, NRHS, A,
$ LDA, B, LDB, WORK, LWORK, INFO )
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'SGETSLS ', INFO, 0,
$ ', NB=', I4, ', type', I2, ', test(', I2, ')=', G12.5 )
9998 FORMAT( ' M=', I5, ', N=', I5, ', NRHS=', I4, ', NB=', I4,
$ ', type', I2, ', test(', I2, ')=', G12.5 )
- 9997 FORMAT( ' TRANS=''', A1,' M=', I5, ', N=', I5, ', NRHS=', I4,
- $ ', MB=', I4,', NB=', I4,', type', I2,
+ 9997 FORMAT( ' TRANS=''', A1,' M=', I5, ', N=', I5, ', NRHS=', I4,
+ $ ', MB=', I4,', NB=', I4,', type', I2,
$ ', test(', I2, ')=', G12.5 )
RETURN
*
* Check error code from SSYSV_AASEN .
*
IF( INFO.NE.K ) THEN
- CALL ALAERH( PATH, 'SSYSV_AASEN ', INFO, K,
- $ UPLO, N, N, -1, -1, NRHS,
+ CALL ALAERH( PATH, 'SSYSV_AASEN ', INFO, K,
+ $ UPLO, N, N, -1, -1, NRHS,
$ IMAT, NFAIL, NERRS, NOUT )
GO TO 120
ELSE IF( INFO.NE.0 ) THEN
* residual.
*
CALL SSYT01_AASEN( UPLO, N, A, LDA, AFAC, LDA,
- $ IWORK, AINV, LDA, RWORK,
+ $ IWORK, AINV, LDA, RWORK,
$ RESULT( 1 ) )
*
* Compute residual of the computed solution.
*
* =========== DOCUMENTATION ===========
*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE SERRLQT( PATH, NUNIT )
-*
+*
* .. Scalar Arguments ..
* CHARACTER*3 PATH
* INTEGER NUNIT
* ..
-*
+*
*
*> \par Purpose:
* =============
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
*> \date November 2011
*
* ..
* .. External Subroutines ..
EXTERNAL ALAESM, CHKXER, SGELQT3, SGELQT,
- $ SGEMLQT
+ $ SGEMLQT
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
*
* =========== DOCUMENTATION ===========
*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE SERRLQTP( PATH, NUNIT )
-*
+*
* .. Scalar Arguments ..
* CHARACTER*3 PATH
* INTEGER NUNIT
* ..
-*
+*
*
*> \par Purpose:
* =============
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
*> \date November 2011
*
* ..
* .. External Subroutines ..
EXTERNAL ALAESM, CHKXER, STPLQT2, STPLQT,
- $ STPMLQT
+ $ STPMLQT
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
*
SRNAMT = 'STPMLQT'
INFOT = 1
- CALL STPMLQT( '/', 'N', 0, 0, 0, 0, 1, A, 1, T, 1, B, 1, C, 1,
+ CALL STPMLQT( '/', 'N', 0, 0, 0, 0, 1, A, 1, T, 1, B, 1, C, 1,
$ W, INFO )
CALL CHKXER( 'STPMLQT', INFOT, NOUT, LERR, OK )
INFOT = 2
- CALL STPMLQT( 'L', '/', 0, 0, 0, 0, 1, A, 1, T, 1, B, 1, C, 1,
+ CALL STPMLQT( 'L', '/', 0, 0, 0, 0, 1, A, 1, T, 1, B, 1, C, 1,
$ W, INFO )
CALL CHKXER( 'STPMLQT', INFOT, NOUT, LERR, OK )
INFOT = 3
- CALL STPMLQT( 'L', 'N', -1, 0, 0, 0, 1, A, 1, T, 1, B, 1, C, 1,
+ CALL STPMLQT( 'L', 'N', -1, 0, 0, 0, 1, A, 1, T, 1, B, 1, C, 1,
$ W, INFO )
CALL CHKXER( 'STPMLQT', INFOT, NOUT, LERR, OK )
INFOT = 4
- CALL STPMLQT( 'L', 'N', 0, -1, 0, 0, 1, A, 1, T, 1, B, 1, C, 1,
+ CALL STPMLQT( 'L', 'N', 0, -1, 0, 0, 1, A, 1, T, 1, B, 1, C, 1,
$ W, INFO )
CALL CHKXER( 'STPMLQT', INFOT, NOUT, LERR, OK )
INFOT = 5
- CALL STPMLQT( 'L', 'N', 0, 0, -1, 0, 1, A, 1, T, 1, B, 1, C, 1,
+ CALL STPMLQT( 'L', 'N', 0, 0, -1, 0, 1, A, 1, T, 1, B, 1, C, 1,
$ W, INFO )
INFOT = 6
- CALL STPMLQT( 'L', 'N', 0, 0, 0, -1, 1, A, 1, T, 1, B, 1, C, 1,
+ CALL STPMLQT( 'L', 'N', 0, 0, 0, -1, 1, A, 1, T, 1, B, 1, C, 1,
$ W, INFO )
CALL CHKXER( 'STPMLQT', INFOT, NOUT, LERR, OK )
INFOT = 7
- CALL STPMLQT( 'L', 'N', 0, 0, 0, 0, 0, A, 1, T, 1, B, 1, C, 1,
+ CALL STPMLQT( 'L', 'N', 0, 0, 0, 0, 0, A, 1, T, 1, B, 1, C, 1,
$ W, INFO )
CALL CHKXER( 'STPMLQT', INFOT, NOUT, LERR, OK )
INFOT = 9
- CALL STPMLQT( 'R', 'N', 2, 2, 2, 1, 1, A, 1, T, 1, B, 1, C, 1,
+ CALL STPMLQT( 'R', 'N', 2, 2, 2, 1, 1, A, 1, T, 1, B, 1, C, 1,
$ W, INFO )
CALL CHKXER( 'STPMLQT', INFOT, NOUT, LERR, OK )
INFOT = 11
- CALL STPMLQT( 'R', 'N', 1, 1, 1, 1, 1, A, 1, T, 0, B, 1, C, 1,
+ CALL STPMLQT( 'R', 'N', 1, 1, 1, 1, 1, A, 1, T, 0, B, 1, C, 1,
$ W, INFO )
CALL CHKXER( 'STPMLQT', INFOT, NOUT, LERR, OK )
INFOT = 13
- CALL STPMLQT( 'L', 'N', 1, 1, 1, 1, 1, A, 1, T, 1, B, 0, C, 1,
+ CALL STPMLQT( 'L', 'N', 1, 1, 1, 1, 1, A, 1, T, 1, B, 0, C, 1,
$ W, INFO )
CALL CHKXER( 'STPMLQT', INFOT, NOUT, LERR, OK )
INFOT = 15
- CALL STPMLQT( 'L', 'N', 1, 1, 1, 1, 1, A, 1, T, 1, B, 1, C, 0,
+ CALL STPMLQT( 'L', 'N', 1, 1, 1, 1, 1, A, 1, T, 1, B, 1, C, 0,
$ W, INFO )
CALL CHKXER( 'STPMLQT', INFOT, NOUT, LERR, OK )
*
*
* =========== DOCUMENTATION ===========
*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE SERRTSQR( PATH, NUNIT )
-*
+*
* .. Scalar Arguments ..
* CHARACTER*3 PATH
* INTEGER NUNIT
* ..
-*
+*
*
*> \par Purpose:
* =============
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
*> \date November 2011
*
*
* =========== DOCUMENTATION ===========
*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE SLQT04(M,N,NB,RESULT)
-*
+*
* .. Scalar Arguments ..
* INTEGER M, N, NB, LDT
* .. Return values ..
* REAL RESULT(6)
-*
+*
*
*> \par Purpose:
* =============
*> RESULT(2) = | I - Q Q^H |
*> RESULT(3) = | Q C - Q C |
*> RESULT(4) = | Q^H C - Q^H C |
-*> RESULT(5) = | C Q - C Q |
+*> RESULT(5) = | C Q - C Q |
*> RESULT(6) = | C Q^H - C Q^H |
*> \endverbatim
*
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
*> \date April 2012
*
* =====================================================================
*
* ..
-* .. Local allocatable arrays
+* .. Local allocatable arrays
REAL, ALLOCATABLE :: AF(:,:), Q(:,:),
- $ L(:,:), RWORK(:), WORK( : ), T(:,:),
+ $ L(:,:), RWORK(:), WORK( : ), T(:,:),
$ CF(:,:), DF(:,:), A(:,:), C(:,:), D(:,:)
*
* .. Parameters ..
EXTERNAL SLAMCH, SLANGE, SLANSY, LSAME
* ..
* .. Intrinsic Functions ..
- INTRINSIC MAX, MIN
+ INTRINSIC MAX, MIN
* ..
* .. Data statements ..
- DATA ISEED / 1988, 1989, 1990, 1991 /
-*
+ DATA ISEED / 1988, 1989, 1990, 1991 /
+*
EPS = SLAMCH( 'Epsilon' )
K = MIN(M,N)
LL = MAX(M,N)
*
* Dynamically allocate local arrays
*
- ALLOCATE ( A(M,N), AF(M,N), Q(N,N), L(LL,N), RWORK(LL),
- $ WORK(LWORK), T(NB,N), C(M,N), CF(M,N),
+ ALLOCATE ( A(M,N), AF(M,N), Q(N,N), L(LL,N), RWORK(LL),
+ $ WORK(LWORK), T(NB,N), C(M,N), CF(M,N),
$ D(N,M), DF(N,M) )
*
* Put random numbers into A and copy to AF
* Generate the n-by-n matrix Q
*
CALL SLASET( 'Full', N, N, ZERO, ONE, Q, N )
- CALL SGEMLQT( 'R', 'N', N, N, K, NB, AF, M, T, LDT, Q, N,
+ CALL SGEMLQT( 'R', 'N', N, N, K, NB, AF, M, T, LDT, Q, N,
$ WORK, INFO )
*
* Copy R
*
* Apply Q to C as Q*C
*
- CALL SGEMLQT( 'L', 'N', N, M, K, NB, AF, M, T, NB, DF, N,
+ CALL SGEMLQT( 'L', 'N', N, M, K, NB, AF, M, T, NB, DF, N,
$ WORK, INFO)
*
* Compute |Q*D - Q*D| / |D|
*
* Apply Q to D as QT*D
*
- CALL SGEMLQT( 'L', 'T', N, M, K, NB, AF, M, T, NB, DF, N,
+ CALL SGEMLQT( 'L', 'T', N, M, K, NB, AF, M, T, NB, DF, N,
$ WORK, INFO)
*
* Compute |QT*D - QT*D| / |D|
RESULT( 4 ) = RESID / (EPS*MAX(1,M)*DNORM)
ELSE
RESULT( 4 ) = ZERO
- END IF
+ END IF
*
* Generate random n-by-m matrix D and a copy DF
*
*
* Apply Q to C as C*Q
*
- CALL SGEMLQT( 'R', 'N', M, N, K, NB, AF, M, T, NB, CF, M,
- $ WORK, INFO)
+ CALL SGEMLQT( 'R', 'N', M, N, K, NB, AF, M, T, NB, CF, M,
+ $ WORK, INFO)
*
* Compute |C*Q - C*Q| / |C|
*
*
* Apply Q to D as D*QT
*
- CALL SGEMLQT( 'R', 'T', M, N, K, NB, AF, M, T, NB, CF, M,
- $ WORK, INFO)
+ CALL SGEMLQT( 'R', 'T', M, N, K, NB, AF, M, T, NB, CF, M,
+ $ WORK, INFO)
*
* Compute |C*QT - C*QT| / |C|
*
* ===========
*
* SUBROUTINE SLQT05(M,N,L,NB,RESULT)
-*
+*
* .. Scalar Arguments ..
* INTEGER LWORK, M, N, L, NB, LDT
* .. Return values ..
* REAL RESULT(6)
-*
+*
*
*> \par Purpose:
* =============
*> The number of rows of the upper trapezoidal part the
*> lower test matrix. 0 <= L <= M.
*> \endverbatim
-*>
+*>
*> \param[in] NB
*> \verbatim
*> NB is INTEGER
*> RESULT(2) = | I - Q^H Q |
*> RESULT(3) = | Q C - Q C |
*> RESULT(4) = | Q^H C - Q^H C |
-*> RESULT(5) = | C Q - C Q |
+*> RESULT(5) = | C Q - C Q |
*> RESULT(6) = | C Q^H - C Q^H |
*> \endverbatim
*
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
*> \date April 2012
*
REAL RESULT(6)
*
* =====================================================================
-*
+*
* ..
-* .. Local allocatable arrays
+* .. Local allocatable arrays
REAL, ALLOCATABLE :: AF(:,:), Q(:,:),
- $ R(:,:), RWORK(:), WORK( : ), T(:,:),
+ $ R(:,:), RWORK(:), WORK( : ), T(:,:),
$ CF(:,:), DF(:,:), A(:,:), C(:,:), D(:,:)
*
* .. Parameters ..
* ..
* .. Data statements ..
DATA ISEED / 1988, 1989, 1990, 1991 /
-*
+*
EPS = SLAMCH( 'Epsilon' )
K = M
N2 = M+N
* Dynamically allocate all arrays
*
ALLOCATE(A(M,N2),AF(M,N2),Q(N2,N2),R(N2,N2),RWORK(N2),
- $ WORK(LWORK),T(NB,M),C(N2,M),CF(N2,M),
+ $ WORK(LWORK),T(NB,M),C(N2,M),CF(N2,M),
$ D(M,N2),DF(M,N2) )
*
* Put random stuff into A
END IF
IF( L.GT.0 ) THEN
DO J=1,L
- CALL SLARNV( 2, ISEED, M-J+1, A( J, MIN(N+M,N+M-L+1)
+ CALL SLARNV( 2, ISEED, M-J+1, A( J, MIN(N+M,N+M-L+1)
$ + J - 1 ) )
END DO
END IF
CALL SLACPY( 'Full', N2, M, C, N2, CF, N2 )
*
* Apply Q to C as Q*C
-*
+*
CALL STPMLQT( 'L','N', N,M,K,L,NB,AF(1, NP1),M,T,LDT,CF,N2,
$ CF(NP1,1),N2,WORK,INFO)
*
* Apply Q to C as QT*C
*
CALL STPMLQT( 'L','T',N,M,K,L,NB,AF(1,NP1),M,T,LDT,CF,N2,
- $ CF(NP1,1),N2,WORK,INFO)
+ $ CF(NP1,1),N2,WORK,INFO)
*
* Compute |QT*C - QT*C| / |C|
*
CALL SGEMM('T','N',N2,M,N2,-ONE,Q,N2,C,N2,ONE,CF,N2)
RESID = SLANGE( '1', N2, M, CF, N2, RWORK )
-
+
IF( CNORM.GT.ZERO ) THEN
RESULT( 4 ) = RESID / (EPS*MAX(1,N2)*CNORM)
ELSE
RESULT( 4 ) = ZERO
- END IF
+ END IF
*
* Generate random m-by-n matrix D and a copy DF
*
* Apply Q to D as D*QT
*
CALL STPMLQT('R','T',M,N,K,L,NB,AF(1,NP1),M,T,LDT,DF,M,
- $ DF(1,NP1),M,WORK,INFO)
-
+ $ DF(1,NP1),M,WORK,INFO)
+
*
* Compute |D*QT - D*QT| / |D|
*
*
DEALLOCATE ( A, AF, Q, R, RWORK, WORK, T, C, D, CF, DF)
RETURN
- END
\ No newline at end of file
+ END
*
* SUBROUTINE STPLQT( M, N, L, MB, A, LDA, B, LDB, T, LDT, WORK,
* INFO )
-*
+*
* .. Scalar Arguments ..
* INTEGER INFO, LDA, LDB, LDT, N, M, L, MB
* ..
* .. Array Arguments ..
* REAL A( LDA, * ), B( LDB, * ), T( LDT, * ), WORK( * )
* ..
-*
+*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
-*> STPLQT computes a blocked LQ factorization of a real
-*> "triangular-pentagonal" matrix C, which is composed of a
-*> triangular block A and pentagonal block B, using the compact
+*> STPLQT computes a blocked LQ factorization of a real
+*> "triangular-pentagonal" matrix C, which is composed of a
+*> triangular block A and pentagonal block B, using the compact
*> WY representation for Q.
*> \endverbatim
*
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix B, and the order of the
-*> triangular matrix A.
+*> triangular matrix A.
*> M >= 0.
*> \endverbatim
*>
*> \param[in,out] B
*> \verbatim
*> B is REAL array, dimension (LDB,N)
-*> On entry, the pentagonal M-by-N matrix B. The first N-L columns
+*> On entry, the pentagonal M-by-N matrix B. The first N-L columns
*> are rectangular, and the last L columns are lower trapezoidal.
*> On exit, B contains the pentagonal matrix V. See Further Details.
*> \endverbatim
*> The lower triangular block reflectors stored in compact form
*> as a sequence of upper triangular blocks. See Further Details.
*> \endverbatim
-*>
+*>
*> \param[in] LDT
*> \verbatim
*> LDT is INTEGER
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
*> \date November 2013
*
*>
*> \verbatim
*>
-*> The input matrix C is a M-by-(M+N) matrix
+*> The input matrix C is a M-by-(M+N) matrix
*>
*> C = [ A ] [ B ]
-*>
+*>
*>
*> where A is an lower triangular N-by-N matrix, and B is M-by-N pentagonal
*> matrix consisting of a M-by-(N-L) rectangular matrix B1 on left of a M-by-L
*> upper trapezoidal matrix B2:
-*> [ B ] = [ B1 ] [ B2 ]
+*> [ B ] = [ B1 ] [ B2 ]
*> [ B1 ] <- M-by-(N-L) rectangular
*> [ B2 ] <- M-by-L upper trapezoidal.
*>
*> The lower trapezoidal matrix B2 consists of the first L columns of a
-*> N-by-N lower triangular matrix, where 0 <= L <= MIN(M,N). If L=0,
-*> B is rectangular M-by-N; if M=L=N, B is lower triangular.
+*> N-by-N lower triangular matrix, where 0 <= L <= MIN(M,N). If L=0,
+*> B is rectangular M-by-N; if M=L=N, B is lower triangular.
*>
*> The matrix W stores the elementary reflectors H(i) in the i-th row
*> above the diagonal (of A) in the M-by-(M+N) input matrix C
-*> [ C ] = [ A ] [ B ]
+*> [ C ] = [ A ] [ B ]
*> [ A ] <- lower triangular N-by-N
*> [ B ] <- M-by-N pentagonal
*>
*> so that W can be represented as
-*> [ W ] = [ I ] [ V ]
+*> [ W ] = [ I ] [ V ]
*> [ I ] <- identity, N-by-N
*> [ V ] <- M-by-N, same form as B.
*>
*> Thus, all of information needed for W is contained on exit in B, which
-*> we call V above. Note that V has the same form as B; that is,
-*> [ V ] = [ V1 ] [ V2 ]
+*> we call V above. Note that V has the same form as B; that is,
+*> [ V ] = [ V1 ] [ V2 ]
*> [ V1 ] <- M-by-(N-L) rectangular
*> [ V2 ] <- M-by-L lower trapezoidal.
*>
-*> The rows of V represent the vectors which define the H(i)'s.
+*> The rows of V represent the vectors which define the H(i)'s.
*>
*> The number of blocks is B = ceiling(M/MB), where each
-*> block is of order MB except for the last block, which is of order
+*> block is of order MB except for the last block, which is of order
*> IB = M - (M-1)*MB. For each of the B blocks, a upper triangular block
-*> reflector factor is computed: T1, T2, ..., TB. The MB-by-MB (and IB-by-IB
+*> reflector factor is computed: T1, T2, ..., TB. The MB-by-MB (and IB-by-IB
*> for the last block) T's are stored in the MB-by-N matrix T as
*>
*> T = [T1 T2 ... TB].
IF( M.EQ.0 .OR. N.EQ.0 ) RETURN
*
DO I = 1, M, MB
-*
+*
* Compute the QR factorization of the current block
*
IB = MIN( M-I+1, MB )
LB = NB-N+L-I+1
END IF
*
- CALL STPLQT2( IB, NB, LB, A(I,I), LDA, B( I, 1 ), LDB,
+ CALL STPLQT2( IB, NB, LB, A(I,I), LDA, B( I, 1 ), LDB,
$ T(1, I ), LDT, IINFO )
*
* Update by applying H**T to B(I+IB:M,:) from the right
*
IF( I+IB.LE.M ) THEN
CALL STPRFB( 'R', 'N', 'F', 'R', M-I-IB+1, NB, IB, LB,
- $ B( I, 1 ), LDB, T( 1, I ), LDT,
- $ A( I+IB, I ), LDA, B( I+IB, 1 ), LDB,
+ $ B( I, 1 ), LDB, T( 1, I ), LDT,
+ $ A( I+IB, I ), LDA, B( I+IB, 1 ), LDB,
$ WORK, M-I-IB+1)
END IF
END DO
RETURN
-*
+*
* End of STPLQT
*
END
*
* =========== DOCUMENTATION ===========
*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE STSQR01(TSSW, M,N, MB, NB, RESULT)
-*
+*
* .. Scalar Arguments ..
* INTEGER M, N, MB
* .. Return values ..
* REAL RESULT(6)
-*
+*
*
*> \par Purpose:
* =============
*> RESULT(2) = | I - Q^H Q | or | I - Q Q^H |
*> RESULT(3) = | Q C - Q C |
*> RESULT(4) = | Q^H C - Q^H C |
-*> RESULT(5) = | C Q - C Q |
+*> RESULT(5) = | C Q - C Q |
*> RESULT(6) = | C Q^H - C Q^H |
*> \endverbatim
*
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
*> \date April 2012
*
* =====================================================================
*
* ..
-* .. Local allocatable arrays
+* .. Local allocatable arrays
REAL, ALLOCATABLE :: AF(:,:), Q(:,:),
- $ R(:,:), RWORK(:), WORK( : ), T(:),
+ $ R(:,:), RWORK(:), WORK( : ), T(:),
$ CF(:,:), DF(:,:), A(:,:), C(:,:), D(:,:), LQ(:,:)
*
* .. Parameters ..
EXTERNAL SLAMCH, SLARNV, SLANGE, SLANSY, LSAME, ILAENV
* ..
* .. Intrinsic Functions ..
- INTRINSIC MAX, MIN
+ INTRINSIC MAX, MIN
* .. Scalars in Common ..
CHARACTER*32 srnamt
* ..
* .. Common blocks ..
- COMMON / srnamc / srnamt
+ COMMON / srnamc / srnamt
* ..
* .. Data statements ..
- DATA ISEED / 1988, 1989, 1990, 1991 /
+ DATA ISEED / 1988, 1989, 1990, 1991 /
*
* TEST TALL SKINNY OR SHORT WIDE
*
- TS = LSAME(TSSW, 'TS')
-*
+ TS = LSAME(TSSW, 'TS')
+*
* TEST MATRICES WITH HALF OF MATRIX BEING ZEROS
*
TESTZEROS = .FALSE.
-*
+*
EPS = SLAMCH( 'Epsilon' )
K = MIN(M,N)
L = MAX(M,N,1)
IF((K.GE.MNB).OR.(MNB.GE.L))THEN
LT=MAX(1,L)*MNB+5
ELSE
- LT=MAX(1,(L-K)/(MNB-K)+1)*L*MNB+5
+ LT=MAX(1,(L-K)/(MNB-K)+1)*L*MNB+5
END IF
*
* Dynamically allocate local arrays
*
- ALLOCATE ( A(M,N), AF(M,N), Q(L,L), R(M,L), RWORK(L),
- $ WORK(LWORK), T(LT), C(M,N), CF(M,N),
+ ALLOCATE ( A(M,N), AF(M,N), Q(L,L), R(M,L), RWORK(L),
+ $ WORK(LWORK), T(LT), C(M,N), CF(M,N),
$ D(N,M), DF(N,M), LQ(L,N) )
*
* Put random numbers into A and copy to AF
*
CALL SLASET( 'Full', M, M, ZERO, ONE, Q, M )
srnamt = 'SGEMQR'
- CALL SGEMQR( 'L', 'N', M, M, K, AF, M, T, LT, Q, M,
+ CALL SGEMQR( 'L', 'N', M, M, K, AF, M, T, LT, Q, M,
$ WORK, LWORK, INFO )
*
* Copy R
* Apply Q to C as Q*C
*
srnamt = 'DGEQR'
- CALL SGEMQR( 'L', 'N', M, N, K, AF, M, T, LT, CF, M,
+ CALL SGEMQR( 'L', 'N', M, N, K, AF, M, T, LT, CF, M,
$ WORK, LWORK, INFO)
*
* Compute |Q*C - Q*C| / |C|
* Apply Q to C as QT*C
*
srnamt = 'DGEQR'
- CALL SGEMQR( 'L', 'T', M, N, K, AF, M, T, LT, CF, M,
+ CALL SGEMQR( 'L', 'T', M, N, K, AF, M, T, LT, CF, M,
$ WORK, LWORK, INFO)
*
* Compute |QT*C - QT*C| / |C|
RESULT( 4 ) = RESID / (EPS*MAX(1,M)*CNORM)
ELSE
RESULT( 4 ) = ZERO
- END IF
+ END IF
*
* Generate random n-by-m matrix D and a copy DF
*
* Apply Q to D as D*Q
*
srnamt = 'DGEQR'
- CALL SGEMQR( 'R', 'N', N, M, K, AF, M, T, LT, DF, N,
- $ WORK, LWORK, INFO)
+ CALL SGEMQR( 'R', 'N', N, M, K, AF, M, T, LT, DF, N,
+ $ WORK, LWORK, INFO)
*
* Compute |D*Q - D*Q| / |D|
*
*
* Apply Q to D as D*QT
*
- CALL SGEMQR( 'R', 'T', N, M, K, AF, M, T, LT, DF, N,
- $ WORK, LWORK, INFO)
+ CALL SGEMQR( 'R', 'T', N, M, K, AF, M, T, LT, DF, N,
+ $ WORK, LWORK, INFO)
*
* Compute |D*QT - D*QT| / |D|
*
*
CALL SLASET( 'Full', N, N, ZERO, ONE, Q, N )
srnamt = 'SGEMQR'
- CALL SGEMLQ( 'R', 'N', N, N, K, AF, M, T, LT, Q, N,
+ CALL SGEMLQ( 'R', 'N', N, N, K, AF, M, T, LT, Q, N,
$ WORK, LWORK, INFO )
*
* Copy R
*
* Apply Q to C as Q*C
*
- CALL SGEMLQ( 'L', 'N', N, M, K, AF, M, T, LT, DF, N,
+ CALL SGEMLQ( 'L', 'N', N, M, K, AF, M, T, LT, DF, N,
$ WORK, LWORK, INFO)
*
* Compute |Q*D - Q*D| / |D|
*
* Apply Q to D as QT*D
*
- CALL SGEMLQ( 'L', 'T', N, M, K, AF, M, T, LT, DF, N,
+ CALL SGEMLQ( 'L', 'T', N, M, K, AF, M, T, LT, DF, N,
$ WORK, LWORK, INFO)
*
* Compute |QT*D - QT*D| / |D|
RESULT( 4 ) = RESID / (EPS*MAX(1,N)*DNORM)
ELSE
RESULT( 4 ) = ZERO
- END IF
+ END IF
*
* Generate random n-by-m matrix D and a copy DF
*
*
* Apply Q to C as C*Q
*
- CALL SGEMLQ( 'R', 'N', M, N, K, AF, M, T, LT, CF, M,
- $ WORK, LWORK, INFO)
+ CALL SGEMLQ( 'R', 'N', M, N, K, AF, M, T, LT, CF, M,
+ $ WORK, LWORK, INFO)
*
* Compute |C*Q - C*Q| / |C|
*
*
* Apply Q to D as D*QT
*
- CALL SGEMLQ( 'R', 'T', M, N, K, AF, M, T, LT, CF, M,
- $ WORK, LWORK, INFO)
+ CALL SGEMLQ( 'R', 'T', M, N, K, AF, M, T, LT, CF, M,
+ $ WORK, LWORK, INFO)
*
* Compute |C*QT - C*QT| / |C|
*
DEALLOCATE ( A, AF, Q, R, RWORK, WORK, T, C, D, CF, DF)
*
RETURN
- END
\ No newline at end of file
+ END
*
IF( TSTCHK ) THEN
CALL ZCHKHE_AASEN( DOTYPE, NN, NVAL, NNB2, NBVAL2, NNS,
- $ NSVAL, THRESH, TSTERR, LDA,
+ $ NSVAL, THRESH, TSTERR, LDA,
$ A( 1, 1 ), A( 1, 2 ), A( 1, 3 ),
$ B( 1, 1 ), B( 1, 2 ), B( 1, 3 ),
$ WORK, RWORK, IWORK, NOUT )
*
IF( TSTDRV ) THEN
CALL ZDRVHE_AASEN( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR,
- $ LDA, A( 1, 1 ), A( 1, 2 ), A( 1, 3 ),
- $ B( 1, 1 ), B( 1, 2 ), B( 1, 3 ),
+ $ LDA, A( 1, 1 ), A( 1, 2 ), A( 1, 3 ),
+ $ B( 1, 1 ), B( 1, 2 ), B( 1, 3 ),
$ WORK, RWORK, IWORK, NOUT )
ELSE
WRITE( NOUT, FMT = 9988 )PATH
* XQ: LQT routines for triangular-pentagonal matrices
*
IF( TSTCHK ) THEN
- CALL ZCHKLQTP( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
+ CALL ZCHKLQTP( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
$ NBVAL, NOUT )
ELSE
WRITE( NOUT, FMT = 9989 )PATH
* TS: QR routines for tall-skinny matrices
*
IF( TSTCHK ) THEN
- CALL ZCHKTSQR( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
+ CALL ZCHKTSQR( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
$ NBVAL, NOUT )
ELSE
WRITE( NOUT, FMT = 9989 )PATH
* .. External Subroutines ..
EXTERNAL ALAERH, ALAHD, ALASUM, XLAENV, ZERRHE, ZGET04,
$ ZHECON, ZHERFS, ZHET01, ZHETRF_AASEN, ZHETRI2,
- $ ZHETRS_AASEN, ZLACPY, ZLAIPD, ZLARHS, ZLATB4,
+ $ ZHETRS_AASEN, ZLACPY, ZLAIPD, ZLARHS, ZLATB4,
$ ZLATMS, ZPOT02, ZPOT03, ZPOT05
* ..
* .. Intrinsic Functions ..
*
LWORK = ( NB+1 )*LDA
SRNAMT = 'ZHETRF_AASEN'
- CALL ZHETRF_AASEN( UPLO, N, AFAC, LDA, IWORK, AINV,
+ CALL ZHETRF_AASEN( UPLO, N, AFAC, LDA, IWORK, AINV,
$ LWORK, INFO )
*
* Adjust the expected value of INFO to account for
* Check error code from ZHETRF and handle error.
*
IF( INFO.NE.K ) THEN
- CALL ALAERH( PATH, 'ZHETRF_AASEN', INFO, K, UPLO,
- $ N, N, -1, -1, NB, IMAT, NFAIL, NERRS,
+ CALL ALAERH( PATH, 'ZHETRF_AASEN', INFO, K, UPLO,
+ $ N, N, -1, -1, NB, IMAT, NFAIL, NERRS,
$ NOUT )
END IF
*
*
SRNAMT = 'ZLARHS'
CALL ZLARHS( MATPATH, XTYPE, UPLO, ' ', N, N,
- $ KL, KU, NRHS, A, LDA, XACT, LDA,
+ $ KL, KU, NRHS, A, LDA, XACT, LDA,
$ B, LDA, ISEED, INFO )
CALL ZLACPY( 'Full', N, NRHS, B, LDA, X, LDA )
*
*
* =========== DOCUMENTATION ===========
*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
-* SUBROUTINE ZCHKLQT( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
+* SUBROUTINE ZCHKLQT( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
* NBVAL, NOUT )
-*
+*
* .. Scalar Arguments ..
* LOGICAL TSTERR
* INTEGER NM, NN, NNB, NOUT
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup double_lin
*
* =====================================================================
- SUBROUTINE ZCHKLQT( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
+ SUBROUTINE ZCHKLQT( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
$ NBVAL, NOUT )
IMPLICIT NONE
*
NB = NBVAL( K )
*
* Test ZGELQT and ZUNMLQT
-*
+*
IF( (NB.LE.MINMN).AND.(NB.GT.0) ) THEN
CALL ZLQT04( M, N, NB, RESULT )
*
*
* =========== DOCUMENTATION ===========
*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
-* SUBROUTINE ZCHKLQTP( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
+* SUBROUTINE ZCHKLQTP( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
* NBVAL, NOUT )
*
* .. Scalar Arguments ..
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup double_lin
*
* =====================================================================
- SUBROUTINE ZCHKLQTP( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
+ SUBROUTINE ZCHKLQTP( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
$ NBVAL, NOUT )
IMPLICIT NONE
*
*
MINMN = MIN( M, N )
DO L = 0, MINMN, MAX( MINMN, 1 )
-*
+*
* Do for each possible value of NB
*
DO K = 1, NNB
NB = NBVAL( K )
*
* Test DTPLQT and DTPMLQT
-*
+*
IF( (NB.LE.M).AND.(NB.GT.0) ) THEN
CALL ZLQT05( M, N, L, NB, RESULT )
*
*
* End of ZCHKLQTP
*
- END
\ No newline at end of file
+ END
*
* =========== DOCUMENTATION ===========
*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
-* SUBROUTINE ZCHKTSQR( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
+* SUBROUTINE ZCHKTSQR( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
* NBVAL, NOUT )
-*
+*
* .. Scalar Arguments ..
* LOGICAL TSTERR
* INTEGER NM, NN, NNB, NOUT
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup double_lin
*
* =====================================================================
- SUBROUTINE ZCHKTSQR( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
+ SUBROUTINE ZCHKTSQR( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
$ NBVAL, NOUT )
IMPLICIT NONE
*
DOUBLE PRECISION RESULT( NTESTS )
* ..
* .. External Subroutines ..
- EXTERNAL ALAERH, ALAHD, ALASUM, DERRTSQR,
+ EXTERNAL ALAERH, ALAHD, ALASUM, DERRTSQR,
$ DTSQR01, XLAENV
* ..
* .. Intrinsic Functions ..
- INTRINSIC MAX, MIN
+ INTRINSIC MAX, MIN
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
DO J = 1, NN
N = NVAL( J )
IF (MIN(M,N).NE.0) THEN
- DO INB = 1, NNB
+ DO INB = 1, NNB
MB = NBVAL( INB )
CALL XLAENV( 1, MB )
DO IMB = 1, NNB
CALL XLAENV( 2, NB )
*
* Test ZGEQR and ZGEMQR
-*
+*
CALL ZTSQR01( 'TS', M, N, MB, NB, RESULT )
*
* Print information about the tests that did not
END IF
END DO
NRUN = NRUN + NTESTS
- END DO
- END DO
- END IF
+ END DO
+ END DO
+ END IF
END DO
END DO
*
DO J = 1, NN
N = NVAL( J )
IF (MIN(M,N).NE.0) THEN
- DO INB = 1, NNB
+ DO INB = 1, NNB
MB = NBVAL( INB )
CALL XLAENV( 1, MB )
DO IMB = 1, NNB
CALL XLAENV( 2, NB )
*
* Test ZGELQ and ZGEMLQ
-*
+*
CALL ZTSQR01( 'SW', M, N, MB, NB, RESULT )
*
* Print information about the tests that did not
END IF
END DO
NRUN = NRUN + NTESTS
- END DO
- END DO
- END IF
+ END DO
+ END DO
+ END IF
END DO
END DO
*
*
* =====================================================================
SUBROUTINE ZDRVHE_AASEN( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR,
- $ NMAX, A, AFAC, AINV, B, X, XACT, WORK,
+ $ NMAX, A, AFAC, AINV, B, X, XACT, WORK,
$ RWORK, IWORK, NOUT )
*
* -- LAPACK test routine (version 3.7.0) --
* ..
* .. External Subroutines ..
EXTERNAL ALADHD, ALAERH, ALASVM, XLAENV, ZERRVX, ZGET04,
- $ ZHESV_AASEN, ZHET01_AASEN, ZHETRF_AASEN,
+ $ ZHESV_AASEN, ZHET01_AASEN, ZHETRF_AASEN,
$ ZHETRI2, ZLACPY, ZLAIPD, ZLARHS, ZLATB4, ZLATMS,
$ ZPOT02
* ..
* residual.
*
CALL ZHET01_AASEN( UPLO, N, A, LDA, AFAC, LDA,
- $ IWORK, AINV, LDA, RWORK,
+ $ IWORK, AINV, LDA, RWORK,
$ RESULT( 1 ) )
*
* Compute residual of the computed solution.
$ COPYB, LDB, B, LDB )
END IF
SRNAMT = 'DGETSLS '
- CALL ZGETSLS( TRANS, M, N, NRHS, A,
+ CALL ZGETSLS( TRANS, M, N, NRHS, A,
$ LDA, B, LDB, WORK, LWORK, INFO )
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'ZGETSLS ', INFO, 0,
$ ', NB=', I4, ', type', I2, ', test(', I2, ')=', G12.5 )
9998 FORMAT( ' M=', I5, ', N=', I5, ', NRHS=', I4, ', NB=', I4,
$ ', type', I2, ', test(', I2, ')=', G12.5 )
- 9997 FORMAT( ' TRANS=''', A1,' M=', I5, ', N=', I5, ', NRHS=', I4,
- $ ', MB=', I4,', NB=', I4,', type', I2,
+ 9997 FORMAT( ' TRANS=''', A1,' M=', I5, ', N=', I5, ', NRHS=', I4,
+ $ ', MB=', I4,', NB=', I4,', type', I2,
$ ', test(', I2, ')=', G12.5 )
RETURN
*
*
* =========== DOCUMENTATION ===========
*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE ZERRLQT( PATH, NUNIT )
-*
+*
* .. Scalar Arguments ..
* CHARACTER*3 PATH
* INTEGER NUNIT
* ..
-*
+*
*
*> \par Purpose:
* =============
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
*> \date November 2011
*
* ..
* .. External Subroutines ..
EXTERNAL ALAESM, CHKXER, ZGELQT3, ZGELQT,
- $ ZGEMLQT
+ $ ZGEMLQT
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
*
* =========== DOCUMENTATION ===========
*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE ZERRLQTP( PATH, NUNIT )
-*
+*
* .. Scalar Arguments ..
* CHARACTER*3 PATH
* INTEGER NUNIT
* ..
-*
+*
*
*> \par Purpose:
* =============
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
*> \date November 2011
*
* ..
* .. External Subroutines ..
EXTERNAL ALAESM, CHKXER, ZTPLQT2, ZTPLQT,
- $ ZTPMLQT
+ $ ZTPMLQT
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
*
SRNAMT = 'ZTPMLQT'
INFOT = 1
- CALL ZTPMLQT( '/', 'N', 0, 0, 0, 0, 1, A, 1, T, 1, B, 1, C, 1,
+ CALL ZTPMLQT( '/', 'N', 0, 0, 0, 0, 1, A, 1, T, 1, B, 1, C, 1,
$ W, INFO )
CALL CHKXER( 'ZTPMLQT', INFOT, NOUT, LERR, OK )
INFOT = 2
- CALL ZTPMLQT( 'L', '/', 0, 0, 0, 0, 1, A, 1, T, 1, B, 1, C, 1,
+ CALL ZTPMLQT( 'L', '/', 0, 0, 0, 0, 1, A, 1, T, 1, B, 1, C, 1,
$ W, INFO )
CALL CHKXER( 'ZTPMLQT', INFOT, NOUT, LERR, OK )
INFOT = 3
- CALL ZTPMLQT( 'L', 'N', -1, 0, 0, 0, 1, A, 1, T, 1, B, 1, C, 1,
+ CALL ZTPMLQT( 'L', 'N', -1, 0, 0, 0, 1, A, 1, T, 1, B, 1, C, 1,
$ W, INFO )
CALL CHKXER( 'ZTPMLQT', INFOT, NOUT, LERR, OK )
INFOT = 4
- CALL ZTPMLQT( 'L', 'N', 0, -1, 0, 0, 1, A, 1, T, 1, B, 1, C, 1,
+ CALL ZTPMLQT( 'L', 'N', 0, -1, 0, 0, 1, A, 1, T, 1, B, 1, C, 1,
$ W, INFO )
CALL CHKXER( 'ZTPMLQT', INFOT, NOUT, LERR, OK )
INFOT = 5
- CALL ZTPMLQT( 'L', 'N', 0, 0, -1, 0, 1, A, 1, T, 1, B, 1, C, 1,
+ CALL ZTPMLQT( 'L', 'N', 0, 0, -1, 0, 1, A, 1, T, 1, B, 1, C, 1,
$ W, INFO )
INFOT = 6
- CALL ZTPMLQT( 'L', 'N', 0, 0, 0, -1, 1, A, 1, T, 1, B, 1, C, 1,
+ CALL ZTPMLQT( 'L', 'N', 0, 0, 0, -1, 1, A, 1, T, 1, B, 1, C, 1,
$ W, INFO )
CALL CHKXER( 'ZTPMLQT', INFOT, NOUT, LERR, OK )
INFOT = 7
- CALL ZTPMLQT( 'L', 'N', 0, 0, 0, 0, 0, A, 1, T, 1, B, 1, C, 1,
+ CALL ZTPMLQT( 'L', 'N', 0, 0, 0, 0, 0, A, 1, T, 1, B, 1, C, 1,
$ W, INFO )
CALL CHKXER( 'ZTPMLQT', INFOT, NOUT, LERR, OK )
INFOT = 9
- CALL ZTPMLQT( 'R', 'N', 2, 2, 2, 1, 1, A, 1, T, 1, B, 1, C, 1,
+ CALL ZTPMLQT( 'R', 'N', 2, 2, 2, 1, 1, A, 1, T, 1, B, 1, C, 1,
$ W, INFO )
CALL CHKXER( 'ZTPMLQT', INFOT, NOUT, LERR, OK )
INFOT = 11
- CALL ZTPMLQT( 'R', 'N', 1, 1, 1, 1, 1, A, 1, T, 0, B, 1, C, 1,
+ CALL ZTPMLQT( 'R', 'N', 1, 1, 1, 1, 1, A, 1, T, 0, B, 1, C, 1,
$ W, INFO )
CALL CHKXER( 'ZTPMLQT', INFOT, NOUT, LERR, OK )
INFOT = 13
- CALL ZTPMLQT( 'L', 'N', 1, 1, 1, 1, 1, A, 1, T, 1, B, 0, C, 1,
+ CALL ZTPMLQT( 'L', 'N', 1, 1, 1, 1, 1, A, 1, T, 1, B, 0, C, 1,
$ W, INFO )
CALL CHKXER( 'ZTPMLQT', INFOT, NOUT, LERR, OK )
INFOT = 15
- CALL ZTPMLQT( 'L', 'N', 1, 1, 1, 1, 1, A, 1, T, 1, B, 1, C, 0,
+ CALL ZTPMLQT( 'L', 'N', 1, 1, 1, 1, 1, A, 1, T, 1, B, 1, C, 0,
$ W, INFO )
CALL CHKXER( 'ZTPMLQT', INFOT, NOUT, LERR, OK )
*
*
* =========== DOCUMENTATION ===========
*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE ZERRTSQR( PATH, NUNIT )
-*
+*
* .. Scalar Arguments ..
* CHARACTER*3 PATH
* INTEGER NUNIT
* ..
-*
+*
*
*> \par Purpose:
* =============
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Zenver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Zenver
+*> \author NAG Ltd.
*
*> \date November 2011
*
*
* .. Parameters ..
COMPLEX*16 CZERO, CONE
- PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ),
+ PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ),
$ CONE = ( 1.0D+0, 0.0D+0 ) )
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
*
* =========== DOCUMENTATION ===========
*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE ZLQT04(M,N,NB,RESULT)
-*
+*
* .. Scalar Arguments ..
* INTEGER M, N, NB
* .. Return values ..
* DOUBLE PRECISION RESULT(6)
-*
+*
*
*> \par Purpose:
* =============
*> RESULT(2) = | I - Q Q^H |
*> RESULT(3) = | Q C - Q C |
*> RESULT(4) = | Q^H C - Q^H C |
-*> RESULT(5) = | C Q - C Q |
+*> RESULT(5) = | C Q - C Q |
*> RESULT(6) = | C Q^H - C Q^H |
*> \endverbatim
*
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
*> \date April 2012
*
* =====================================================================
*
* ..
-* .. Local allocatable arrays
+* .. Local allocatable arrays
COMPLEX*16, ALLOCATABLE :: AF(:,:), Q(:,:),
- $ L(:,:), RWORK(:), WORK( : ), T(:,:),
+ $ L(:,:), RWORK(:), WORK( : ), T(:,:),
$ CF(:,:), DF(:,:), A(:,:), C(:,:), D(:,:)
*
* .. Parameters ..
EXTERNAL DLAMCH, ZLANGE, ZLANSY, LSAME
* ..
* .. Intrinsic Functions ..
- INTRINSIC MAX, MIN
+ INTRINSIC MAX, MIN
* ..
* .. Data statements ..
- DATA ISEED / 1988, 1989, 1990, 1991 /
-*
+ DATA ISEED / 1988, 1989, 1990, 1991 /
+*
EPS = DLAMCH( 'Epsilon' )
K = MIN(M,N)
LL = MAX(M,N)
*
* Dynamically allocate local arrays
*
- ALLOCATE ( A(M,N), AF(M,N), Q(N,N), L(LL,N), RWORK(LL),
- $ WORK(LWORK), T(NB,N), C(M,N), CF(M,N),
+ ALLOCATE ( A(M,N), AF(M,N), Q(N,N), L(LL,N), RWORK(LL),
+ $ WORK(LWORK), T(NB,N), C(M,N), CF(M,N),
$ D(N,M), DF(N,M) )
*
* Put random numbers into A and copy to AF
* Generate the n-by-n matrix Q
*
CALL ZLASET( 'Full', N, N, CZERO, ONE, Q, N )
- CALL ZGEMLQT( 'R', 'N', N, N, K, NB, AF, M, T, LDT, Q, N,
+ CALL ZGEMLQT( 'R', 'N', N, N, K, NB, AF, M, T, LDT, Q, N,
$ WORK, INFO )
*
* Copy L
*
* Apply Q to C as Q*C
*
- CALL ZGEMLQT( 'L', 'N', N, M, K, NB, AF, M, T, NB, DF, N,
+ CALL ZGEMLQT( 'L', 'N', N, M, K, NB, AF, M, T, NB, DF, N,
$ WORK, INFO)
*
* Compute |Q*D - Q*D| / |D|
*
* Apply Q to D as QT*D
*
- CALL ZGEMLQT( 'L', 'C', N, M, K, NB, AF, M, T, NB, DF, N,
+ CALL ZGEMLQT( 'L', 'C', N, M, K, NB, AF, M, T, NB, DF, N,
$ WORK, INFO)
*
* Compute |QT*D - QT*D| / |D|
RESULT( 4 ) = RESID / (EPS*MAX(1,M)*DNORM)
ELSE
RESULT( 4 ) = ZERO
- END IF
+ END IF
*
* Generate random n-by-m matrix D and a copy DF
*
*
* Apply Q to C as C*Q
*
- CALL ZGEMLQT( 'R', 'N', M, N, K, NB, AF, M, T, NB, CF, M,
- $ WORK, INFO)
+ CALL ZGEMLQT( 'R', 'N', M, N, K, NB, AF, M, T, NB, CF, M,
+ $ WORK, INFO)
*
* Compute |C*Q - C*Q| / |C|
*
*
* Apply Q to D as D*QT
*
- CALL ZGEMLQT( 'R', 'C', M, N, K, NB, AF, M, T, NB, CF, M,
- $ WORK, INFO)
+ CALL ZGEMLQT( 'R', 'C', M, N, K, NB, AF, M, T, NB, CF, M,
+ $ WORK, INFO)
*
* Compute |C*QT - C*QT| / |C|
*
*
* =========== DOCUMENTATION ===========
*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE ZLQT05(M,N,L,NB,RESULT)
-*
+*
* .. Scalar Arguments ..
* INTEGER LWORK, M, N, L, NB, LDT
* .. Return values ..
* DOUBLE PRECISION RESULT(6)
-*
+*
*
*> \par Purpose:
* =============
*> The number of rows of the upper trapezoidal part the
*> lower test matrix. 0 <= L <= M.
*> \endverbatim
-*>
+*>
*> \param[in] NB
*> \verbatim
*> NB is INTEGER
*> RESULT(2) = | I - Q^H Q |
*> RESULT(3) = | Q C - Q C |
*> RESULT(4) = | Q^H C - Q^H C |
-*> RESULT(5) = | C Q - C Q |
+*> RESULT(5) = | C Q - C Q |
*> RESULT(6) = | C Q^H - C Q^H |
*> \endverbatim
*
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
*> \date April 2012
*
DOUBLE PRECISION RESULT(6)
*
* =====================================================================
-*
+*
* ..
-* .. Local allocatable arrays
+* .. Local allocatable arrays
COMPLEX*16, ALLOCATABLE :: AF(:,:), Q(:,:),
- $ R(:,:), RWORK(:), WORK( : ), T(:,:),
+ $ R(:,:), RWORK(:), WORK( : ), T(:,:),
$ CF(:,:), DF(:,:), A(:,:), C(:,:), D(:,:)
*
* .. Parameters ..
* ..
* .. Data statements ..
DATA ISEED / 1988, 1989, 1990, 1991 /
-*
+*
EPS = DLAMCH( 'Epsilon' )
K = M
N2 = M+N
* Dynamically allocate all arrays
*
ALLOCATE(A(M,N2),AF(M,N2),Q(N2,N2),R(N2,N2),RWORK(N2),
- $ WORK(LWORK),T(NB,M),C(N2,M),CF(N2,M),
+ $ WORK(LWORK),T(NB,M),C(N2,M),CF(N2,M),
$ D(M,N2),DF(M,N2) )
*
* Put random stuff into A
END IF
IF( L.GT.0 ) THEN
DO J=1,L
- CALL ZLARNV( 2, ISEED, M-J+1, A( J, MIN(N+M,N+M-L+1)
+ CALL ZLARNV( 2, ISEED, M-J+1, A( J, MIN(N+M,N+M-L+1)
$ + J - 1 ) )
END DO
END IF
CALL ZLACPY( 'Full', N2, M, C, N2, CF, N2 )
*
* Apply Q to C as Q*C
-*
+*
CALL ZTPMLQT( 'L','N', N,M,K,L,NB,AF(1, NP1),M,T,LDT,CF,N2,
$ CF(NP1,1),N2,WORK,INFO)
*
* Apply Q to C as QT*C
*
CALL ZTPMLQT( 'L','C',N,M,K,L,NB,AF(1,NP1),M,T,LDT,CF,N2,
- $ CF(NP1,1),N2,WORK,INFO)
+ $ CF(NP1,1),N2,WORK,INFO)
*
* Compute |QT*C - QT*C| / |C|
*
CALL ZGEMM('C','N',N2,M,N2,-ONE,Q,N2,C,N2,ONE,CF,N2)
RESID = ZLANGE( '1', N2, M, CF, N2, RWORK )
-
+
IF( CNORM.GT.ZERO ) THEN
RESULT( 4 ) = RESID / (EPS*MAX(1,N2)*CNORM)
ELSE
RESULT( 4 ) = ZERO
- END IF
+ END IF
*
* Generate random m-by-n matrix D and a copy DF
*
* Apply Q to D as D*QT
*
CALL ZTPMLQT('R','C',M,N,K,L,NB,AF(1,NP1),M,T,LDT,DF,M,
- $ DF(1,NP1),M,WORK,INFO)
-
+ $ DF(1,NP1),M,WORK,INFO)
+
*
* Compute |D*QT - D*QT| / |D|
*
*
DEALLOCATE ( A, AF, Q, R, RWORK, WORK, T, C, D, CF, DF)
RETURN
- END
\ No newline at end of file
+ END
*
* =========== DOCUMENTATION ===========
*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE ZTSQR01(TSSW, M,N, MB, NB, RESULT)
-*
+*
* .. Scalar Arguments ..
* INTEGER M, N, MB
* .. Return values ..
* DOUBLE PRECISION RESULT(6)
-*
+*
*
*> \par Purpose:
* =============
*> RESULT(2) = | I - Q^H Q | or | I - Q Q^H |
*> RESULT(3) = | Q C - Q C |
*> RESULT(4) = | Q^H C - Q^H C |
-*> RESULT(5) = | C Q - C Q |
+*> RESULT(5) = | C Q - C Q |
*> RESULT(6) = | C Q^H - C Q^H |
*> \endverbatim
*
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
*> \date April 2012
*
* =====================================================================
*
* ..
-* .. Local allocatable arrays
+* .. Local allocatable arrays
COMPLEX*16, ALLOCATABLE :: AF(:,:), Q(:,:),
- $ R(:,:), RWORK(:), WORK( : ), T(:),
+ $ R(:,:), RWORK(:), WORK( : ), T(:),
$ CF(:,:), DF(:,:), A(:,:), C(:,:), D(:,:), LQ(:,:)
*
* .. Parameters ..
EXTERNAL DLAMCH, ZLANGE, ZLANSY, LSAME, ILAENV
* ..
* .. Intrinsic Functions ..
- INTRINSIC MAX, MIN
+ INTRINSIC MAX, MIN
* .. Scalars in Common ..
CHARACTER*32 srnamt
* ..
* .. Common blocks ..
- COMMON / srnamc / srnamt
+ COMMON / srnamc / srnamt
* ..
* .. Data statements ..
- DATA ISEED / 1988, 1989, 1990, 1991 /
+ DATA ISEED / 1988, 1989, 1990, 1991 /
*
* TEST TALL SKINNY OR SHORT WIDE
*
- TS = LSAME(TSSW, 'TS')
-*
+ TS = LSAME(TSSW, 'TS')
+*
* TEST MATRICES WITH HALF OF MATRIX BEING ZEROS
*
TESTZEROS = .FALSE.
-*
+*
EPS = DLAMCH( 'Epsilon' )
K = MIN(M,N)
L = MAX(M,N,1)
IF((K.GE.MNB).OR.(MNB.GE.L))THEN
LT=MAX(1,L)*MNB+5
ELSE
- LT=MAX(1,(L-K)/(MNB-K)+1)*L*MNB+5
+ LT=MAX(1,(L-K)/(MNB-K)+1)*L*MNB+5
END IF
*
* Dynamically allocate local arrays
*
- ALLOCATE ( A(M,N), AF(M,N), Q(L,L), R(M,L), RWORK(L),
- $ WORK(LWORK), T(LT), C(M,N), CF(M,N),
+ ALLOCATE ( A(M,N), AF(M,N), Q(L,L), R(M,L), RWORK(L),
+ $ WORK(LWORK), T(LT), C(M,N), CF(M,N),
$ D(N,M), DF(N,M), LQ(L,N) )
*
* Put random numbers into A and copy to AF
*
CALL ZLASET( 'Full', M, M, CZERO, ONE, Q, M )
srnamt = 'ZGEMQR'
- CALL ZGEMQR( 'L', 'N', M, M, K, AF, M, T, LT, Q, M,
+ CALL ZGEMQR( 'L', 'N', M, M, K, AF, M, T, LT, Q, M,
$ WORK, LWORK, INFO )
*
* Copy R
* Apply Q to C as Q*C
*
srnamt = 'ZGEMQR'
- CALL ZGEMQR( 'L', 'N', M, N, K, AF, M, T, LT, CF, M,
+ CALL ZGEMQR( 'L', 'N', M, N, K, AF, M, T, LT, CF, M,
$ WORK, LWORK, INFO)
*
* Compute |Q*C - Q*C| / |C|
* Apply Q to C as QT*C
*
srnamt = 'ZGEMQR'
- CALL ZGEMQR( 'L', 'C', M, N, K, AF, M, T, LT, CF, M,
+ CALL ZGEMQR( 'L', 'C', M, N, K, AF, M, T, LT, CF, M,
$ WORK, LWORK, INFO)
*
* Compute |QT*C - QT*C| / |C|
RESULT( 4 ) = RESID / (EPS*MAX(1,M)*CNORM)
ELSE
RESULT( 4 ) = ZERO
- END IF
+ END IF
*
* Generate random n-by-m matrix D and a copy DF
*
* Apply Q to D as D*Q
*
srnamt = 'ZGEMQR'
- CALL ZGEMQR( 'R', 'N', N, M, K, AF, M, T, LT, DF, N,
- $ WORK, LWORK, INFO)
+ CALL ZGEMQR( 'R', 'N', N, M, K, AF, M, T, LT, DF, N,
+ $ WORK, LWORK, INFO)
*
* Compute |D*Q - D*Q| / |D|
*
*
* Apply Q to D as D*QT
*
- CALL ZGEMQR( 'R', 'C', N, M, K, AF, M, T, LT, DF, N,
- $ WORK, LWORK, INFO)
+ CALL ZGEMQR( 'R', 'C', N, M, K, AF, M, T, LT, DF, N,
+ $ WORK, LWORK, INFO)
*
* Compute |D*QT - D*QT| / |D|
*
*
CALL ZLASET( 'Full', N, N, CZERO, ONE, Q, N )
srnamt = 'ZGEMLQ'
- CALL ZGEMLQ( 'R', 'N', N, N, K, AF, M, T, LT, Q, N,
+ CALL ZGEMLQ( 'R', 'N', N, N, K, AF, M, T, LT, Q, N,
$ WORK, LWORK, INFO )
*
* Copy R
*
* Apply Q to C as Q*C
*
- CALL ZGEMLQ( 'L', 'N', N, M, K, AF, M, T, LT, DF, N,
+ CALL ZGEMLQ( 'L', 'N', N, M, K, AF, M, T, LT, DF, N,
$ WORK, LWORK, INFO)
*
* Compute |Q*D - Q*D| / |D|
*
* Apply Q to D as QT*D
*
- CALL ZGEMLQ( 'L', 'C', N, M, K, AF, M, T, LT, DF, N,
+ CALL ZGEMLQ( 'L', 'C', N, M, K, AF, M, T, LT, DF, N,
$ WORK, LWORK, INFO)
*
* Compute |QT*D - QT*D| / |D|
RESULT( 4 ) = RESID / (EPS*MAX(1,N)*DNORM)
ELSE
RESULT( 4 ) = ZERO
- END IF
+ END IF
*
* Generate random n-by-m matrix D and a copy DF
*
*
* Apply Q to C as C*Q
*
- CALL ZGEMLQ( 'R', 'N', M, N, K, AF, M, T, LT, CF, M,
- $ WORK, LWORK, INFO)
+ CALL ZGEMLQ( 'R', 'N', M, N, K, AF, M, T, LT, CF, M,
+ $ WORK, LWORK, INFO)
*
* Compute |C*Q - C*Q| / |C|
*
*
* Apply Q to D as D*QT
*
- CALL ZGEMLQ( 'R', 'C', M, N, K, AF, M, T, LT, CF, M,
- $ WORK, LWORK, INFO)
+ CALL ZGEMLQ( 'R', 'C', M, N, K, AF, M, T, LT, CF, M,
+ $ WORK, LWORK, INFO)
*
* Compute |C*QT - C*QT| / |C|
*
DEALLOCATE ( A, AF, Q, R, RWORK, WORK, T, C, D, CF, DF)
*
RETURN
- END
\ No newline at end of file
+ END
projects / platform / upstream / lapack.git / commitdiff