# precision.
# ZLASRC -- Double precision complex LAPACK routines
# ZXLASRC -- Double precision complex LAPACK routines using extra
-# precision.
+# precision.
#
# DEPRECATED -- Deprecated routines in all precisions
#
ssytd2.o ssytf2.o ssytrd.o ssytrf.o ssytri.o ssytri2.o ssytri2x.o \
ssyswapr.o ssytrs.o ssytrs2.o ssyconv.o \
ssytf2_rook.o ssytrf_rook.o ssytrs_rook.o \
- slasyf_aasen.o ssysv_aasen.o ssytrf_aasen.o ssytrs_aasen.o \
ssytri_rook.o ssycon_rook.o ssysv_rook.o \
stbcon.o \
stbrfs.o stbtrs.o stgevc.o stgex2.o stgexc.o stgsen.o \
sbbcsd.o slapmr.o sorbdb.o sorbdb1.o sorbdb2.o sorbdb3.o sorbdb4.o \
sorbdb5.o sorbdb6.o sorcsd.o sorcsd2by1.o \
sgeqrt.o sgeqrt2.o sgeqrt3.o sgemqrt.o \
- stpqrt.o stpqrt2.o stpmqrt.o stprfb.o
+ stpqrt.o stpqrt2.o stpmqrt.o stprfb.o \
+ sgelqt.o sgelqt3.o sgemlqt.o \
+ sgetsls.o sgeqr.o slatsqr.o slamtsqr.o sgemqr.o \
+ sgelq.o slaswlq.o slamswlq.o sgemlq.o \
+ stplqt.o stplqt2.o stpmlqt.o
-DSLASRC = spotrs.o sgetrs.o spotrf.o sgetrf.o
+DSLASRC = spotrs.o sgetrs.o spotrf.o sgetrf.o
ifdef USEXBLAS
SXLASRC = sgesvxx.o sgerfsx.o sla_gerfsx_extended.o sla_geamv.o \
chetrf.o chetri.o chetri2.o chetri2x.o cheswapr.o \
chetrs.o chetrs2.o \
chetf2_rook.o chetrf_rook.o chetri_rook.o chetrs_rook.o checon_rook.o chesv_rook.o \
- chesv_aasen.o chetrf_aasen.o chetrs_aasen.o clahef_aasen.o\
chgeqz.o chpcon.o chpev.o chpevd.o \
chpevx.o chpgst.o chpgv.o chpgvd.o chpgvx.o chprfs.o chpsv.o \
chpsvx.o \
cbbcsd.o clapmr.o cunbdb.o cunbdb1.o cunbdb2.o cunbdb3.o cunbdb4.o \
cunbdb5.o cunbdb6.o cuncsd.o cuncsd2by1.o \
cgeqrt.o cgeqrt2.o cgeqrt3.o cgemqrt.o \
- ctpqrt.o ctpqrt2.o ctpmqrt.o ctprfb.o
+ ctpqrt.o ctpqrt2.o ctpmqrt.o ctprfb.o \
+ cgelqt.o cgelqt3.o cgemlqt.o \
+ cgetsls.o cgeqr.o clatsqr.o clamtsqr.o cgemqr.o \
+ cgelq.o claswlq.o clamswlq.o cgemlq.o \
+ ctplqt.o ctplqt2.o ctpmlqt.o
ifdef USEXBLAS
CXLASRC = cgesvxx.o cgerfsx.o cla_gerfsx_extended.o cla_geamv.o \
cla_lin_berr.o clarscl2.o clascl2.o cla_wwaddw.o
endif
-ZCLASRC = cpotrs.o cgetrs.o cpotrf.o cgetrf.o
+ZCLASRC = cpotrs.o cgetrs.o cpotrf.o cgetrf.o
DLASRC = \
dpotrf2.o dgetrf2.o \
dsytd2.o dsytf2.o dsytrd.o dsytrf.o dsytri.o dsytri2.o dsytri2x.o \
dsyswapr.o dsytrs.o dsytrs2.o dsyconv.o \
dsytf2_rook.o dsytrf_rook.o dsytrs_rook.o \
- dlasyf_aasen.o dsysv_aasen.o dsytrf_aasen.o dsytrs_aasen.o \
dsytri_rook.o dsycon_rook.o dsysv_rook.o \
dtbcon.o dtbrfs.o dtbtrs.o dtgevc.o dtgex2.o dtgexc.o dtgsen.o \
dtgsja.o dtgsna.o dtgsy2.o dtgsyl.o dtpcon.o dtprfs.o dtptri.o \
dbbcsd.o dlapmr.o dorbdb.o dorbdb1.o dorbdb2.o dorbdb3.o dorbdb4.o \
dorbdb5.o dorbdb6.o dorcsd.o dorcsd2by1.o \
dgeqrt.o dgeqrt2.o dgeqrt3.o dgemqrt.o \
- dtpqrt.o dtpqrt2.o dtpmqrt.o dtprfb.o
+ dtpqrt.o dtpqrt2.o dtpmqrt.o dtprfb.o \
+ dgelqt.o dgelqt3.o dgemlqt.o \
+ dgetsls.o dgeqr.o dlatsqr.o dlamtsqr.o dgemqr.o \
+ dgelq.o dlaswlq.o dlamswlq.o dgemlq.o \
+ dtplqt.o dtplqt2.o dtpmlqt.o
ifdef USEXBLAS
DXLASRC = dgesvxx.o dgerfsx.o dla_gerfsx_extended.o dla_geamv.o \
zhetrf.o zhetri.o zhetri2.o zhetri2x.o zheswapr.o \
zhetrs.o zhetrs2.o \
zhetf2_rook.o zhetrf_rook.o zhetri_rook.o zhetrs_rook.o zhecon_rook.o zhesv_rook.o \
- zhesv_aasen.o zhetrf_aasen.o zhetrs_aasen.o zlahef_aasen.o \
zhgeqz.o zhpcon.o zhpev.o zhpevd.o \
zhpevx.o zhpgst.o zhpgv.o zhpgvd.o zhpgvx.o zhprfs.o zhpsv.o \
zhpsvx.o \
zbbcsd.o zlapmr.o zunbdb.o zunbdb1.o zunbdb2.o zunbdb3.o zunbdb4.o \
zunbdb5.o zunbdb6.o zuncsd.o zuncsd2by1.o \
zgeqrt.o zgeqrt2.o zgeqrt3.o zgemqrt.o \
- ztpqrt.o ztpqrt2.o ztpmqrt.o ztprfb.o
+ ztpqrt.o ztpqrt2.o ztpmqrt.o ztprfb.o \
+ ztplqt.o ztplqt2.o ztpmlqt.o \
+ zgelqt.o zgelqt3.o zgemlqt.o \
+ zgetsls.o zgeqr.o zlatsqr.o zlamtsqr.o zgemqr.o \
+ zgelq.o zlaswlq.o zlamswlq.o zgemlq.o \
+ ztplqt.o ztplqt2.o ztpmlqt.o
ifdef USEXBLAS
ZXLASRC = zgesvxx.o zgerfsx.o zla_gerfsx_extended.o zla_geamv.o \
clean:
rm -f *.o DEPRECATED/*.o
-.f.o:
+.f.o:
$(FORTRAN) $(OPTS) -c $< -o $@
slaruv.o: slaruv.f ; $(FORTRAN) $(NOOPT) -c $< -o $@
--- /dev/null
+*
+* Definition:
+* ===========
+*
+* 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:
+*> A = L * Q .
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows of the matrix A. M >= 0.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of columns of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is COMPLEX 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
+*> (L is lower triangular if M <= N);
+*> the elements above the diagonal are the rows of
+*> blocked V representing Q (see Further Details).
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,M).
+*> \endverbatim
+*>
+*> \param[out] WORK1
+*> \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
+*> 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
+*> CLASWLQ or CGELQT
+*> \endverbatim
+*>
+*> \param[in] LWORK1
+*> \verbatim
+*> LWORK1 is INTEGER
+*> The dimension of the array WORK1.
+*> 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
+*> 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
+*> 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
+*> LWORK2 = -1.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> < 0: if INFO = -i, the i-th argument had an illegal value
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*> 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 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
+*> 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
+*> Further Details in LASWLQ or GELQT.
+*> \endverbatim
+*>
+* =====================================================================
+ SUBROUTINE CGELQ( M, N, A, LDA, WORK1, LWORK1, WORK2, LWORK2,
+ $ INFO)
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd. --
+* November 2013
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, M, N, LWORK1, LWORK2
+* ..
+* .. Array Arguments ..
+ COMPLEX A( LDA, * ), WORK1( * ), WORK2( * )
+* ..
+*
+* =====================================================================
+*
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY, LMINWS
+ INTEGER MB, NB, I, II, KK, MINLW1, NBLCKS
+* ..
+* .. EXTERNAL FUNCTIONS ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* .. EXTERNAL SUBROUTINES ..
+ EXTERNAL CGELQT, CLASWLQ, XERBLA
+* .. INTRINSIC FUNCTIONS ..
+ INTRINSIC MAX, MIN, MOD
+* ..
+* .. EXTERNAL FUNCTIONS ..
+ INTEGER ILAENV
+ EXTERNAL ILAENV
+* ..
+* .. EXECUTABLE STATEMENTS ..
+*
+* TEST THE INPUT ARGUMENTS
+*
+ INFO = 0
+*
+ LQUERY = ( LWORK1.EQ.-1 .OR. LWORK2.EQ.-1 )
+*
+* 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)
+ ELSE
+ MB = 1
+ NB = N
+ END IF
+ IF( MB.GT.MIN(M,N).OR.MB.LT.1) MB = 1
+ IF( NB.GT.N.OR.NB.LE.M) NB = N
+ MINLW1 = M + 5
+ IF ((NB.GT.M).AND.(N.GT.M)) THEN
+ IF(MOD(N-M, NB-M).EQ.0) THEN
+ NBLCKS = (N-M)/(NB-M)
+ ELSE
+ NBLCKS = (N-M)/(NB-M) + 1
+ END IF
+ ELSE
+ NBLCKS = 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)
+ $ .AND.(.NOT.LQUERY)) THEN
+ IF (LWORK1.LT.MAX(1,MB*M*NBLCKS+5)) THEN
+ LMINWS = .TRUE.
+ MB = 1
+ END IF
+ IF (LWORK1.LT.MAX(1,M*NBLCKS+5)) THEN
+ LMINWS = .TRUE.
+ NB = N
+ END IF
+ IF (LWORK2.LT.MB*M) THEN
+ LMINWS = .TRUE.
+ MB = 1
+ END IF
+ END IF
+*
+ IF( M.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -4
+ 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
+*
+ IF( INFO.EQ.0) THEN
+ WORK1(1) = 1
+ WORK1(2) = MB*M*NBLCKS+5
+ WORK1(3) = MINLW1
+ WORK1(4) = MB
+ WORK1(5) = NB
+ WORK2(1) = MB * M
+ WORK2(2) = M
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'CGELQ', -INFO )
+ RETURN
+ ELSE IF (LQUERY) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( MIN(M,N).EQ.0 ) THEN
+ RETURN
+ END IF
+*
+* The LQ Decomposition
+*
+ 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,
+ $ LWORK2, INFO)
+ END IF
+ RETURN
+*
+* End of CGELQ
+*
+ END
\ No newline at end of file
--- /dev/null
+*
+* Definition:
+* ===========
+*
+* 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.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows of the matrix A. M >= 0.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of columns of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in] MB
+*> \verbatim
+*> MB is INTEGER
+*> The block size to be used in the blocked QR. MIN(M,N) >= MB >= 1.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \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 (L is
+*> lower triangular if M <= N); the elements above the diagonal
+*> are the rows of V.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,M).
+*> \endverbatim
+*>
+*> \param[out] T
+*> \verbatim
+*> T is COMPLEX array, dimension (LDT,MIN(M,N))
+*> The upper triangular block reflectors stored in compact form
+*> as a sequence of upper triangular blocks. See below
+*> for further details.
+*> \endverbatim
+*>
+*> \param[in] LDT
+*> \verbatim
+*> LDT is INTEGER
+*> The leading dimension of the array T. LDT >= MB.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is COMPLEX array, dimension (MB*N)
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> < 0: if INFO = -i, the i-th argument had an illegal value
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2013
+*
+*> \ingroup doubleGEcomputational
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*>
+*> The matrix V stores the elementary reflectors H(i) in the i-th column
+*> below the diagonal. For example, if M=5 and N=3, the matrix V is
+*>
+*> 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.
+*> 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
+*> 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
+*> for the last block) T's are stored in the NB-by-N matrix T as
+*>
+*> T = (T1 T2 ... TB).
+*> \endverbatim
+*>
+* =====================================================================
+ SUBROUTINE CGELQT( M, N, MB, A, LDA, T, LDT, WORK, INFO )
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2013
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, LDT, M, N, MB
+* ..
+* .. Array Arguments ..
+ COMPLEX A( LDA, * ), T( LDT, * ), WORK( * )
+* ..
+*
+* =====================================================================
+*
+* ..
+* .. Local Scalars ..
+ INTEGER I, IB, IINFO, K
+* ..
+* .. External Subroutines ..
+ EXTERNAL CGELQT3, CLARFB, XERBLA
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+ IF( M.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( MB.LT.1 .OR. (MB.GT.MIN(M,N) .AND. MIN(M,N).GT.0 ))THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -5
+ ELSE IF( LDT.LT.MB ) THEN
+ INFO = -7
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'CGELQT', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ K = MIN( M, N )
+ IF( K.EQ.0 ) RETURN
+*
+* Blocked loop of length K
+*
+ 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+IB, I ), LDA, WORK , M-I-IB+1 )
+ END IF
+ END DO
+ RETURN
+*
+* End of CGELQT
+*
+ END
--- /dev/null
+* Definition:
+* ===========
+*
+* RECURSIVE SUBROUTINE CGELQT3( M, N, A, LDA, T, LDT, INFO )
+*
+* .. Scalar Arguments ..
+* INTEGER INFO, LDA, M, N, LDT
+* ..
+* .. Array Arguments ..
+* COMPLEX A( LDA, * ), T( LDT, * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> CGELQT3 recursively computes a LQ factorization of a complex M-by-N
+*> matrix A, using the compact WY representation of Q.
+*>
+*> Based on the algorithm of Elmroth and Gustavson,
+*> IBM J. Res. Develop. Vol 44 No. 4 July 2000.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows of the matrix A. M =< N.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of columns of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is COMPLEX array, dimension (LDA,N)
+*> On entry, the real M-by-N matrix A. On exit, the elements on and
+*> below the diagonal contain the N-by-N lower triangular matrix L; the
+*> elements above the diagonal are the rows of V. See below for
+*> further details.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,M).
+*> \endverbatim
+*>
+*> \param[out] T
+*> \verbatim
+*> T is COMPLEX array, dimension (LDT,N)
+*> The N-by-N upper triangular factor of the block reflector.
+*> The elements on and above the diagonal contain the block
+*> reflector T; the elements below the diagonal are not used.
+*> See below for further details.
+*> \endverbatim
+*>
+*> \param[in] LDT
+*> \verbatim
+*> LDT is INTEGER
+*> The leading dimension of the array T. LDT >= max(1,N).
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> < 0: if INFO = -i, the i-th argument had an illegal value
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date September 2012
+*
+*> \ingroup doubleGEcomputational
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*>
+*> The matrix V stores the elementary reflectors H(i) in the i-th column
+*> below the diagonal. For example, if M=5 and N=3, the matrix V is
+*>
+*> 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
+*> block reflector H is then given by
+*>
+*> H = I - V * T * V**T
+*>
+*> where V**T is the transpose of V.
+*>
+*> For details of the algorithm, see Elmroth and Gustavson (cited above).
+*> \endverbatim
+*>
+* =====================================================================
+ RECURSIVE SUBROUTINE CGELQT3( M, N, A, LDA, T, LDT, INFO )
+*
+* -- LAPACK computational routine (version 3.4.2) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* September 2012
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, M, N, LDT
+* ..
+* .. Array Arguments ..
+ COMPLEX A( LDA, * ), T( LDT, * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ COMPLEX ONE, ZERO
+ PARAMETER ( ONE = (1.0E+00,0.0E+00) )
+ PARAMETER ( ZERO = (0.0E+00,0.0E+00))
+* ..
+* .. Local Scalars ..
+ INTEGER I, I1, J, J1, N1, N2, IINFO
+* ..
+* .. External Subroutines ..
+ EXTERNAL CLARFG, CTRMM, CGEMM, XERBLA
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+ IF( M .LT. 0 ) THEN
+ INFO = -1
+ ELSE IF( N .LT. M ) THEN
+ INFO = -2
+ ELSE IF( LDA .LT. MAX( 1, M ) ) THEN
+ INFO = -4
+ ELSE IF( LDT .LT. MAX( 1, M ) ) THEN
+ INFO = -6
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'CGELQT3', -INFO )
+ RETURN
+ END IF
+*
+ IF( M.EQ.1 ) THEN
+*
+* Compute Householder transform when N=1
+*
+ CALL CLARFG( N, A, A( 1, MIN( 2, N ) ), LDA, T )
+ T(1,1)=CONJG(T(1,1))
+*
+ ELSE
+*
+* Otherwise, split A into blocks...
+*
+ M1 = M/2
+ M2 = M-M1
+ I1 = MIN( M1+1, M )
+ J1 = MIN( M+1, N )
+*
+* Compute A(1:M1,1:N) <- (Y1,R1,T1), where Q1 = I - Y1 T1 Y1^H
+*
+ CALL CGELQT3( M1, N, A, LDA, T, LDT, IINFO )
+*
+* Compute A(J1:M,1:N) = A(J1:M,1:N) Q1^H [workspace: T(1:N1,J1:N)]
+*
+ DO I=1,M2
+ DO J=1,M1
+ T( I+M1, J ) = A( I+M1, J )
+ END DO
+ END DO
+ CALL CTRMM( 'R', 'U', 'C', 'U', M2, M1, ONE,
+ & A, LDA, T( I1, 1 ), LDT )
+*
+ CALL CGEMM( 'N', 'C', M2, M1, N-M1, ONE, A( I1, I1 ), LDA,
+ & A( 1, I1 ), LDA, ONE, T( I1, 1 ), LDT)
+*
+ CALL CTRMM( 'R', 'U', 'N', 'N', M2, M1, ONE,
+ & T, LDT, T( I1, 1 ), LDT )
+*
+ CALL CGEMM( 'N', 'N', M2, N-M1, M1, -ONE, T( I1, 1 ), LDT,
+ & A( 1, I1 ), LDA, ONE, A( I1, I1 ), LDA )
+*
+ CALL CTRMM( 'R', 'U', 'N', 'U', M2, M1 , ONE,
+ & A, LDA, T( I1, 1 ), LDT )
+*
+ DO I=1,M2
+ DO J=1,M1
+ A( I+M1, J ) = A( I+M1, J ) - T( I+M1, J )
+ T( I+M1, J )= ZERO
+ END DO
+ END DO
+*
+* Compute A(J1:M,J1:N) <- (Y2,R2,T2) where Q2 = I - Y2 T2 Y2^H
+*
+ CALL CGELQT3( M2, N-M1, A( I1, I1 ), LDA,
+ & T( I1, I1 ), LDT, IINFO )
+*
+* Compute T3 = T(J1:N1,1:N) = -T1 Y1^H Y2 T2
+*
+ DO I=1,M2
+ DO J=1,M1
+ T( J, I+M1 ) = (A( J, I+M1 ))
+ END DO
+ END DO
+*
+ CALL CTRMM( 'R', 'U', 'C', 'U', M1, M2, ONE,
+ & A( I1, I1 ), LDA, T( 1, I1 ), LDT )
+*
+ CALL CGEMM( 'N', 'C', M1, M2, N-M, ONE, A( 1, J1 ), LDA,
+ & A( I1, J1 ), LDA, ONE, T( 1, I1 ), LDT )
+*
+ CALL CTRMM( 'L', 'U', 'N', 'N', M1, M2, -ONE, T, LDT,
+ & T( 1, I1 ), LDT )
+*
+ CALL CTRMM( '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]
+*
+ END IF
+*
+ RETURN
+*
+* End of CGELQT3
+*
+ END
--- /dev/null
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE CGEMLQ( SIDE, TRANS, M, N, K, A, LDA, WORK1,
+* $ LWORK1, C, LDC, WORK2, LWORK2, INFO )
+*
+*
+* .. Scalar Arguments ..
+* CHARACTER SIDE, TRANS
+* INTEGER INFO, LDA, M, N, K, MB, NB, LWORK1, LWORK2, LDC
+* ..
+* .. Array Arguments ..
+* COMPLEX A( LDA, * ), WORK1( * ), C(LDC, * ),
+* $ WORK2( * )
+*> \par Purpose:
+* =============
+*>
+*> \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
+*> factorization (DGELQ)
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] SIDE
+*> SIDE is CHARACTER*1
+*> = 'L': apply Q or Q**T from the Left;
+*> = 'R': apply Q or Q**T from the Right.
+*>
+*> \param[in] TRANS
+*> TRANS is CHARACTER*1
+*> = 'N': No transpose, apply Q;
+*> = 'T': Transpose, apply Q**T.
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows of the matrix A. M >=0.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of columns of the matrix C. N >= M.
+*> \endverbatim
+*>
+*> \param[in] K
+*> \verbatim
+*> K is INTEGER
+*> The number of elementary reflectors whose product defines
+*> the matrix Q.
+*> M >= K >= 0;
+*>
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is COMPLEX array, dimension (LDA,K)
+*> The i-th row must contain the vector which defines the blocked
+*> elementary reflector H(i), for i = 1,2,...,k, as returned by
+*> DLASWLQ in the first k rows of its array argument A.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A.
+*> If SIDE = 'L', LDA >= max(1,M);
+*> if SIDE = 'R', LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in] WORK1
+*> \verbatim
+*> WORK1 is COMPLEX array, dimension (MAX(1,LWORK1)) is
+*> returned by GEQR.
+*> \endverbatim
+*>
+*> \param[in] LWORK1
+*> \verbatim
+*> LWORK1 is INTEGER
+*> The dimension of the array WORK1.
+*> \endverbatim
+*>
+*> \param[in,out] C
+*> C is COMPLEX array, dimension (LDC,N)
+*> On entry, the M-by-N matrix C.
+*> On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.
+*> \param[in] LDC
+*> LDC is INTEGER
+*> The leading dimension of the array C. LDC >= max(1,M).
+*>
+*> \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 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)),
+*> and no error message related to LWORK2 is issued by XERBLA.
+*>
+*> \endverbatim
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> < 0: if INFO = -i, the i-th argument had an illegal value
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*> 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 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
+*> 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
+*> Further Details in LASWLQ or GELQT.
+*> \endverbatim
+*>
+* =====================================================================
+ SUBROUTINE CGEMLQ( SIDE, TRANS, M, N, K, A, LDA, WORK1, LWORK1,
+ $ C, LDC, WORK2, LWORK2, INFO )
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2013
+*
+* .. Scalar Arguments ..
+ CHARACTER SIDE, TRANS
+ INTEGER INFO, LDA, M, N, K, LWORK1, LWORK2, LDC
+* ..
+* .. Array Arguments ..
+ COMPLEX A( LDA, * ), C( LDC, * ), WORK1( * ), WORK2( * )
+* ..
+*
+* =====================================================================
+*
+* ..
+* .. Local Scalars ..
+ LOGICAL LEFT, RIGHT, TRAN, NOTRAN, LQUERY
+ INTEGER I, II, KK, MB, NB, LW, NBLCKS, MN
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* .. External Subroutines ..
+ EXTERNAL CLAMSWLQ, CGEMLQT, XERBLA
+* .. Intrinsic Functions ..
+ INTRINSIC INT, MAX, MIN, MOD
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ LQUERY = LWORK2.LT.0
+ NOTRAN = LSAME( TRANS, 'N' )
+ TRAN = LSAME( TRANS, 'C' )
+ LEFT = LSAME( SIDE, 'L' )
+ RIGHT = LSAME( SIDE, 'R' )
+*
+ MB = INT(WORK1(4))
+ NB = INT(WORK1(5))
+ IF (LEFT) THEN
+ LW = N * MB
+ MN = M
+ ELSE
+ LW = M * MB
+ MN = N
+ END IF
+ IF ((NB.GT.K).AND.(MN.GT.K)) THEN
+ IF(MOD(MN-K, NB-K).EQ.0) THEN
+ NBLCKS = (MN-K)/(NB-K)
+ ELSE
+ NBLCKS = (MN-K)/(NB-K) + 1
+ END IF
+ ELSE
+ NBLCKS = 1
+ END IF
+*
+ INFO = 0
+ IF( .NOT.LEFT .AND. .NOT.RIGHT ) THEN
+ INFO = -1
+ ELSE IF( .NOT.TRAN .AND. .NOT.NOTRAN ) THEN
+ INFO = -2
+ ELSE IF( M.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( N.LT.0) THEN
+ INFO = -4
+ ELSE IF( K.LT.0 ) THEN
+ INFO = -5
+ ELSE IF( LDA.LT.MAX( 1, K ) ) THEN
+ INFO = -7
+ ELSE IF( LWORK1.LT.MAX( 1, MB*K*NBLCKS+5 )) THEN
+ INFO = -9
+ ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
+ INFO = -11
+ ELSE IF(( LWORK2.LT.MAX(1,LW)).AND.(.NOT.LQUERY)) THEN
+ INFO = -13
+ END IF
+*
+ IF( INFO.EQ.0) THEN
+ WORK2(1) = LW
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'CGEMLQ', -INFO )
+ RETURN
+ ELSE IF (LQUERY) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( MIN(M,N,K).EQ.0 ) THEN
+ RETURN
+ 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)
+ ELSE
+ CALL CLAMSWLQ( SIDE, TRANS, M, N, K, MB, NB, A, LDA, WORK1(6),
+ $ MB, C, LDC, WORK2, LWORK2, INFO )
+ END IF
+*
+ WORK2(1) = LW
+ RETURN
+*
+* End of CGEMLQ
+*
+ END
\ No newline at end of file
--- /dev/null
+* Definition:
+* ===========
+*
+* 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:
+* =============
+*>
+*> \verbatim
+*>
+*> CGEMQRT overwrites the general real 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 complex orthogonal matrix defined as the product of K
+*> elementary reflectors:
+*>
+*> Q = H(1) H(2) . . . H(K) = I - V C V**C
+*>
+*> 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
+*
+* Arguments:
+* ==========
+*
+*> \param[in] SIDE
+*> \verbatim
+*> SIDE is CHARACTER*1
+*> = 'L': apply Q or Q**C from the Left;
+*> = 'R': apply Q or Q**C from the Right.
+*> \endverbatim
+*>
+*> \param[in] TRANS
+*> \verbatim
+*> TRANS is CHARACTER*1
+*> = 'N': No transpose, apply Q;
+*> = 'C': Transpose, apply Q**C.
+*> \endverbatim
+*>
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows of the matrix C. M >= 0.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of columns of the matrix C. N >= 0.
+*> \endverbatim
+*>
+*> \param[in] K
+*> \verbatim
+*> K is INTEGER
+*> The number of elementary reflectors whose product defines
+*> the matrix Q.
+*> If SIDE = 'L', M >= K >= 0;
+*> if SIDE = 'R', N >= K >= 0.
+*> \endverbatim
+*>
+*> \param[in] MB
+*> \verbatim
+*> MB is INTEGER
+*> The block size used for the storage of T. K >= MB >= 1.
+*> This must be the same value of MB used to generate T
+*> in DGELQT.
+*> \endverbatim
+*>
+*> \param[in] V
+*> \verbatim
+*> V is COMPLEX array, dimension (LDV,K)
+*> The i-th row must contain the vector which defines the
+*> elementary reflector H(i), for i = 1,2,...,k, as returned by
+*> DGELQT in the first K rows of its array argument A.
+*> \endverbatim
+*>
+*> \param[in] LDV
+*> \verbatim
+*> LDV is INTEGER
+*> The leading dimension of the array V.
+*> If SIDE = 'L', LDA >= max(1,M);
+*> if SIDE = 'R', LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in] T
+*> \verbatim
+*> T is COMPLEX array, dimension (LDT,K)
+*> The upper triangular factors of the block reflectors
+*> as returned by DGELQT, stored as a MB-by-M matrix.
+*> \endverbatim
+*>
+*> \param[in] LDT
+*> \verbatim
+*> LDT is INTEGER
+*> The leading dimension of the array T. LDT >= MB.
+*> \endverbatim
+*>
+*> \param[in,out] C
+*> \verbatim
+*> C is COMPLEX array, dimension (LDC,N)
+*> On entry, the M-by-N matrix C.
+*> On exit, C is overwritten by Q C, Q**C C, C Q**C or C Q.
+*> \endverbatim
+*>
+*> \param[in] LDC
+*> \verbatim
+*> LDC is INTEGER
+*> The leading dimension of the array C. LDC >= max(1,M).
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is COMPLEX array. The dimension of
+*> WORK is N*MB if SIDE = 'L', or M*MB if SIDE = 'R'.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> < 0: if INFO = -i, the i-th argument had an illegal value
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2013
+*
+*> \ingroup doubleGEcomputational
+*
+* =====================================================================
+ SUBROUTINE CGEMLQT( SIDE, TRANS, M, N, K, MB, V, LDV, T, LDT,
+ $ C, LDC, WORK, INFO )
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2013
+*
+* .. Scalar Arguments ..
+ CHARACTER SIDE, TRANS
+ INTEGER INFO, K, LDV, LDC, M, N, MB, LDT
+* ..
+* .. Array Arguments ..
+ COMPLEX V( LDV, * ), C( LDC, * ), T( LDT, * ), WORK( * )
+* ..
+*
+* =====================================================================
+*
+* ..
+* .. Local Scalars ..
+ LOGICAL LEFT, RIGHT, TRAN, NOTRAN
+ INTEGER I, IB, LDWORK, KF, Q
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL XERBLA, CLARFB
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* .. Test the input arguments ..
+*
+ INFO = 0
+ LEFT = LSAME( SIDE, 'L' )
+ RIGHT = LSAME( SIDE, 'R' )
+ TRAN = LSAME( TRANS, 'C' )
+ NOTRAN = LSAME( TRANS, 'N' )
+*
+ IF( LEFT ) THEN
+ LDWORK = MAX( 1, N )
+ ELSE IF ( RIGHT ) THEN
+ LDWORK = MAX( 1, M )
+ END IF
+ IF( .NOT.LEFT .AND. .NOT.RIGHT ) THEN
+ INFO = -1
+ ELSE IF( .NOT.TRAN .AND. .NOT.NOTRAN ) THEN
+ INFO = -2
+ ELSE IF( M.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( K.LT.0) THEN
+ INFO = -5
+ ELSE IF( MB.LT.1 .OR. (MB.GT.K .AND. K.GT.0)) THEN
+ INFO = -6
+ ELSE IF( LDV.LT.MAX( 1, K ) ) THEN
+ INFO = -8
+ ELSE IF( LDT.LT.MB ) THEN
+ INFO = -10
+ ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
+ INFO = -12
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'CGEMLQT', -INFO )
+ RETURN
+ END IF
+*
+* .. Quick return if possible ..
+*
+ IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) RETURN
+*
+ IF( LEFT .AND. NOTRAN ) 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,
+ $ 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,
+ $ C( 1, I ), LDC, WORK, LDWORK )
+ END DO
+*
+ ELSE IF( LEFT .AND. TRAN ) THEN
+*
+ 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,
+ $ C( I, 1 ), LDC, WORK, LDWORK )
+ END DO
+*
+ ELSE IF( RIGHT .AND. NOTRAN ) THEN
+*
+ 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,
+ $ C( 1, I ), LDC, WORK, LDWORK )
+ END DO
+*
+ END IF
+*
+ RETURN
+*
+* End of CGEMLQT
+*
+ END
--- /dev/null
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE CGEMQR( SIDE, TRANS, M, N, K, A, LDA, WORK1,
+* $ LWORK1, C, LDC, WORK2, LWORK2, INFO )
+*
+*
+* .. Scalar Arguments ..
+* CHARACTER SIDE, TRANS
+* INTEGER INFO, LDA, M, N, K, LDT, LWORK1, LWORK2, LDC
+* ..
+* .. Array Arguments ..
+* COMPLEX A( LDA, * ), WORK1( * ), C(LDC, * ),
+* $ WORK2( * )
+*> \par Purpose:
+* =============
+*>
+*> \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
+*> QR factorization (CGEQR)
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] SIDE
+*> SIDE is CHARACTER*1
+*> = 'L': apply Q or Q**T from the Left;
+*> = 'R': apply Q or Q**T from the Right.
+*>
+*> \param[in] TRANS
+*> TRANS is CHARACTER*1
+*> = 'N': No transpose, apply Q;
+*> = 'T': Transpose, apply Q**T.
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows of the matrix A. M >=0.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of columns of the matrix C. M >= N >= 0.
+*> \endverbatim
+*>
+*> \param[in] K
+*> \verbatim
+*> K is INTEGER
+*> The number of elementary reflectors whose product defines
+*> the matrix Q.
+*> N >= K >= 0;
+*>
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is COMPLEX 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
+*> its array argument A.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A.
+*> If SIDE = 'L', LDA >= max(1,M);
+*> if SIDE = 'R', LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in] WORK1
+*> \verbatim
+*> WORK1 is COMPLEX array, dimension (MAX(1,LWORK1)) as
+*> it is returned by GEQR.
+*> \endverbatim
+*>
+*> \param[in] LWORK1
+*> \verbatim
+*> LWORK1 is INTEGER
+*> The dimension of the array WORK1.
+*> \endverbatim
+*>
+*> \param[in,out] C
+*> C is COMPLEX array, dimension (LDC,N)
+*> On entry, the M-by-N matrix C.
+*> On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.
+*>
+*> \param[in] LDC
+*> LDC is INTEGER
+*> The leading dimension of the array C. LDC >= max(1,M).
+*>
+*> \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 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)),
+*> and no error message related to LWORK2 is issued by XERBLA.
+*>
+*> \endverbatim
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> < 0: if INFO = -i, the i-th argument had an illegal value
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*> 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 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
+*> Further Details in LATSQR or GEQRT.
+*> \endverbatim
+*>
+* =====================================================================
+ SUBROUTINE CGEMQR( SIDE, TRANS, M, N, K, A, LDA, WORK1, LWORK1,
+ $ C, LDC, WORK2, LWORK2, INFO )
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2013
+*
+* .. Scalar Arguments ..
+ CHARACTER SIDE, TRANS
+ INTEGER INFO, LDA, M, N, K, LWORK1, LWORK2, LDC
+* ..
+* .. Array Arguments ..
+ COMPLEX A( LDA, * ), WORK1( * ), C(LDC, * ),
+ $ WORK2( * )
+* ..
+*
+* =====================================================================
+*
+* ..
+* .. Local Scalars ..
+ LOGICAL LEFT, RIGHT, TRAN, NOTRAN, LQUERY
+ INTEGER MB, NB, I, II, KK, LW, NBLCKS, MN
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* .. External Subroutines ..
+ EXTERNAL CGEMQRT, CLAMTSQR, XERBLA
+* .. Intrinsic Functions ..
+ INTRINSIC INT, MAX, MIN, MOD
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ LQUERY = LWORK2.LT.0
+ NOTRAN = LSAME( TRANS, 'N' )
+ TRAN = LSAME( TRANS, 'C' )
+ LEFT = LSAME( SIDE, 'L' )
+ RIGHT = LSAME( SIDE, 'R' )
+*
+ MB = INT(WORK1(4))
+ NB = INT(WORK1(5))
+ IF(LEFT) THEN
+ LW = N * NB
+ MN = M
+ ELSE IF(RIGHT) THEN
+ LW = MB * NB
+ MN = N
+ END IF
+*
+ IF ((MB.GT.K).AND.(MN.GT.K)) THEN
+ IF(MOD(MN-K, MB-K).EQ.0) THEN
+ NBLCKS = (MN-K)/(MB-K)
+ ELSE
+ NBLCKS = (MN-K)/(MB-K) + 1
+ END IF
+ ELSE
+ NBLCKS = 1
+ END IF
+*
+ INFO = 0
+ IF( .NOT.LEFT .AND. .NOT.RIGHT ) THEN
+ INFO = -1
+ ELSE IF( .NOT.TRAN .AND. .NOT.NOTRAN ) THEN
+ INFO = -2
+ ELSE IF( M.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( K.LT.0 ) THEN
+ INFO = -5
+ ELSE IF( LDA.LT.MAX( 1, K ) ) THEN
+ INFO = -7
+ ELSE IF( LWORK1.LT.MAX( 1, NB*K*NBLCKS+5 )) THEN
+ INFO = -9
+ ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
+ INFO = -11
+ ELSE IF(( LWORK2.LT.MAX(1,LW)).AND.(.NOT.LQUERY)) THEN
+ INFO = -13
+ 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( INFO.NE.0 ) THEN
+ CALL XERBLA( 'CGEMQR', -INFO )
+ RETURN
+ ELSE IF (LQUERY) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( MIN(M,N,K).EQ.0 ) THEN
+ RETURN
+ 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)
+ ELSE
+ CALL CLAMTSQR( SIDE, TRANS, M, N, K, MB, NB, A, LDA, WORK1(6),
+ $ NB, C, LDC, WORK2, LWORK2, INFO )
+ END IF
+*
+ WORK2(1) = LW
+ RETURN
+*
+* End of CGEMQR
+*
+ END
\ No newline at end of file
--- /dev/null
+*
+* 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:
+*> A = Q * R .
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows of the matrix A. M >= 0.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of columns of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is COMPLEX 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
+*> (R is upper triangular if M >= N);
+*> the elements below the diagonal represent Q (see Further Details).
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,M).
+*> \endverbatim
+*>
+*> \param[out] WORK1
+*> \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
+*> 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
+*> CLATSQR or CGEQRT
+*> \endverbatim
+*>
+*> \param[in] LWORK1
+*> \verbatim
+*> LWORK1 is INTEGER
+*> The dimension of the array WORK1.
+*> 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
+*> 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
+*> 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
+*> LWORK2 = -1.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> < 0: if INFO = -i, the i-th argument had an illegal value
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*> 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 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
+*> Further Details in LATSQR or GEQRT.
+*> \endverbatim
+*>
+* =====================================================================
+ SUBROUTINE CGEQR( M, N, A, LDA, WORK1, LWORK1, WORK2, LWORK2,
+ $ INFO)
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd. --
+* November 2013
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, M, N, LWORK1, LWORK2
+* ..
+* .. Array Arguments ..
+ COMPLEX A( LDA, * ), WORK1( * ), WORK2( * )
+* ..
+*
+* =====================================================================
+*
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY, LMINWS
+ INTEGER MB, NB, I, II, KK, MINLW1, NBLCKS
+* ..
+* .. EXTERNAL FUNCTIONS ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* .. EXTERNAL SUBROUTINES ..
+ EXTERNAL CLATSQR, CGEQRT, XERBLA
+* .. INTRINSIC FUNCTIONS ..
+ INTRINSIC MAX, MIN, MOD
+* ..
+* .. EXTERNAL FUNCTIONS ..
+ INTEGER ILAENV
+ EXTERNAL ILAENV
+* ..
+* .. EXECUTABLE STATEMENTS ..
+*
+* TEST THE INPUT ARGUMENTS
+*
+ INFO = 0
+*
+ LQUERY = ( LWORK1.EQ.-1 .OR. LWORK2.EQ.-1 )
+*
+* 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)
+ ELSE
+ MB = M
+ NB = 1
+ END IF
+ IF( MB.GT.M.OR.MB.LE.N) MB = M
+ IF( NB.GT.MIN(M,N).OR.NB.LT.1) NB = 1
+ MINLW1 = N + 5
+ IF ((MB.GT.N).AND.(M.GT.N)) THEN
+ IF(MOD(M-N, MB-N).EQ.0) THEN
+ NBLCKS = (M-N)/(MB-N)
+ ELSE
+ NBLCKS = (M-N)/(MB-N) + 1
+ END IF
+ ELSE
+ NBLCKS = 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)
+ $ .AND.(.NOT.LQUERY)) THEN
+ IF (LWORK1.LT.MAX(1, NB * N * NBLCKS+5)) THEN
+ LMINWS = .TRUE.
+ NB = 1
+ END IF
+ IF (LWORK1.LT.MAX(1, N * NBLCKS+5)) THEN
+ LMINWS = .TRUE.
+ MB = M
+ END IF
+ IF (LWORK2.LT.NB*N) THEN
+ LMINWS = .TRUE.
+ NB = 1
+ END IF
+ END IF
+*
+ IF( M.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -4
+ 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)
+ $ .AND.(.NOT.LMINWS)) THEN
+ INFO = -8
+ END IF
+*
+ IF( INFO.EQ.0) THEN
+ WORK1(1) = 1
+ WORK1(2) = NB * N * NBLCKS + 5
+ WORK1(3) = MINLW1
+ WORK1(4) = MB
+ WORK1(5) = NB
+ WORK2(1) = NB * N
+ WORK2(2) = N
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'CGEQR', -INFO )
+ RETURN
+ ELSE IF (LQUERY) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( MIN(M,N).EQ.0 ) THEN
+ RETURN
+ END IF
+*
+* The QR Decomposition
+*
+ 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,
+ $ LWORK2, INFO)
+ END IF
+ RETURN
+*
+* End of CGEQR
+*
+ END
\ No newline at end of file
--- /dev/null
+* Definition:
+* ===========
+*
+* SUBROUTINE CGETSLS( 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 ..
+* COMPLEX A( LDA, * ), B( LDB, * ), WORK( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> CGETSLS solves overdetermined or underdetermined real linear systems
+*> involving an M-by-N matrix A, or its transpose, using a tall skinny
+*> QR or short wide LQfactorization of A. It is assumed that A has
+*> full rank.
+*>
+*> The following options are provided:
+*>
+*> 1. If TRANS = 'N' and m >= n: find the least squares solution of
+*> an overdetermined system, i.e., solve the least squares problem
+*> minimize || B - A*X ||.
+*>
+*> 2. If TRANS = 'N' and m < n: find the minimum norm solution of
+*> an underdetermined system A * X = B.
+*>
+*> 3. If TRANS = 'C' and m >= n: find the minimum norm solution of
+*> an undetermined system A**T * X = B.
+*>
+*> 4. If TRANS = 'C' and m < n: find the least squares solution of
+*> an overdetermined system, i.e., solve the least squares problem
+*> minimize || B - A**T * X ||.
+*>
+*> Several right hand side vectors b and solution vectors x can be
+*> handled in a single call; they are stored as the columns of the
+*> M-by-NRHS right hand side matrix B and the N-by-NRHS solution
+*> matrix X.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] TRANS
+*> \verbatim
+*> TRANS is CHARACTER*1
+*> = 'N': the linear system involves A;
+*> = 'C': the linear system involves A**C.
+*> \endverbatim
+*>
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows of the matrix A. M >= 0.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of columns of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in] NRHS
+*> \verbatim
+*> NRHS is INTEGER
+*> The number of right hand sides, i.e., the number of
+*> columns of the matrices B and X. NRHS >=0.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is COMPLEX array, dimension (LDA,N)
+*> On entry, the M-by-N matrix A.
+*> On exit,
+*> if M >= N, A is overwritten by details of its QR
+*> factorization as returned by DGEQRF;
+*> if M < N, A is overwritten by details of its LQ
+*> factorization as returned by DGELQF.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,M).
+*> \endverbatim
+*>
+*> \param[in,out] B
+*> \verbatim
+*> B is COMPLEX array, dimension (LDB,NRHS)
+*> On entry, the matrix B of right hand side vectors, stored
+*> columnwise; B is M-by-NRHS if TRANS = 'N', or N-by-NRHS
+*> if TRANS = 'T'.
+*> On exit, if INFO = 0, B is overwritten by the solution
+*> vectors, stored columnwise:
+*> if TRANS = 'N' and m >= n, rows 1 to n of B contain the least
+*> squares solution vectors; the residual sum of squares for the
+*> solution in each column is given by the sum of squares of
+*> elements N+1 to M in that column;
+*> if TRANS = 'N' and m < n, rows 1 to N of B contain the
+*> minimum norm solution vectors;
+*> if TRANS = 'T' and m >= n, rows 1 to M of B contain the
+*> minimum norm solution vectors;
+*> if TRANS = 'T' and m < n, rows 1 to M of B contain the
+*> least squares solution vectors; the residual sum of squares
+*> for the solution in each column is given by the sum of
+*> squares of elements M+1 to N in that column.
+*> \endverbatim
+*>
+*> \param[in] LDB
+*> \verbatim
+*> LDB is INTEGER
+*> The leading dimension of the array B. LDB >= MAX(1,M,N).
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is COMPLEX array, dimension (MAX(1,LWORK))
+*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*> \endverbatim
+*>
+*> \param[in] LWORK
+*> \verbatim
+*> LWORK is INTEGER
+*> The dimension of the array WORK.
+*> LWORK >= max( 1, MN + max( MN, NRHS ) ).
+*> For optimal performance,
+*> LWORK >= max( 1, MN + max( MN, NRHS )*NB ).
+*> where MN = min(M,N) and NB is the optimum block size.
+*>
+*> If LWORK = -1, then a workspace query is assumed; the routine
+*> only calculates the optimal size of the WORK array, returns
+*> this value as the first entry of the WORK array, and no error
+*> message related to LWORK is issued by XERBLA.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> < 0: if INFO = -i, the i-th argument had an illegal value
+*> > 0: if INFO = i, the i-th diagonal element of the
+*> triangular factor of A is zero, so that A does not have
+*> full rank; the least squares solution could not be
+*> computed.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2011
+*
+* =====================================================================
+ SUBROUTINE CGETSLS( TRANS, M, N, NRHS, A, LDA, B, LDB
+ $ , WORK, LWORK, INFO )
+*
+* -- LAPACK driver routine (version 3.4.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2011
+*
+* .. Scalar Arguments ..
+ CHARACTER TRANS
+ INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS, MB
+* ..
+* .. Array Arguments ..
+ COMPLEX A( LDA, * ), B( LDB, * ), WORK( * )
+*
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
+ COMPLEX CZERO
+ PARAMETER ( CZERO = ( 0.0E+0, 0.0E+0 ) )
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY, TRAN
+ INTEGER I, IASCL, IBSCL, J, MINMN, MAXMN, BROW, LW,
+ $ SCLLEN, MNK, WSIZEO, WSIZEM, LW1, LW2, INFO2
+ REAL ANRM, BIGNUM, BNRM, SMLNUM
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ REAL SLAMCH, CLANGE
+ EXTERNAL LSAME, ILAENV, SLABAD, SLAMCH, CLANGE
+* ..
+* .. External Subroutines ..
+ EXTERNAL CGEQR, CGEMQR, CLASCL, CLASET,
+ $ CTRTRS, XERBLA, CGELQ, CGEMLQ
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC REAL, MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments.
+*
+ INFO=0
+ MINMN = MIN( M, N )
+ MAXMN = MAX( M, N )
+ MNK = MAX(MINMN,NRHS)
+ TRAN = LSAME( TRANS, 'C' )
+*
+ LQUERY = ( LWORK.EQ.-1 )
+ IF( .NOT.( LSAME( TRANS, 'N' ) .OR.
+ $ LSAME( TRANS, 'C' ) ) ) THEN
+ INFO = -1
+ ELSE IF( M.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -6
+ ELSE IF( LDB.LT.MAX( 1, M, N ) ) THEN
+ INFO = -8
+ END IF
+*
+ IF( INFO.EQ.0) THEN
+*
+* Determine the block size and minimum LWORK
+*
+ IF ( M.GE.N ) THEN
+ CALL CGEQR( M, N, A, LDA, WORK(1), -1, WORK(6), -1,
+ $ INFO2)
+ MB = INT(WORK(4))
+ NB = INT(WORK(5))
+ LW = INT(WORK(6))
+ CALL CGEMQR( 'L', TRANS, M, NRHS, N, A, LDA, WORK(1),
+ $ 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 CGELQ( M, N, A, LDA, WORK(1), -1, WORK(6), -1,
+ $ INFO2)
+ MB = INT(WORK(4))
+ NB = INT(WORK(5))
+ LW = INT(WORK(6))
+ CALL CGEMLQ( 'L', TRANS, N, NRHS, M, A, LDA, WORK(1),
+ $ 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)))
+ END IF
+*
+ IF((LWORK.LT.WSIZEO).AND.(.NOT.LQUERY)) THEN
+ INFO=-10
+ END IF
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DGETSLS', -INFO )
+ WORK( 1 ) = REAL( WSIZEO )
+ WORK( 2 ) = REAL( WSIZEM )
+ RETURN
+ ELSE IF (LQUERY) THEN
+ WORK( 1 ) = REAL( WSIZEO )
+ WORK( 2 ) = REAL( WSIZEM )
+ RETURN
+ END IF
+ IF(LWORK.LT.WSIZEO) THEN
+ LW1=INT(WORK(3))
+ LW2=MAX(LW,INT(WORK(6)))
+ ELSE
+ LW1=INT(WORK(2))
+ LW2=MAX(LW,INT(WORK(6)))
+ END IF
+*
+* Quick return if possible
+*
+ IF( MIN( M, N, NRHS ).EQ.0 ) THEN
+ CALL CLASET( 'FULL', MAX( M, N ), NRHS, CZERO, CZERO,
+ $ B, LDB )
+ RETURN
+ END IF
+*
+* Get machine parameters
+*
+ SMLNUM = SLAMCH( 'S' ) / SLAMCH( 'P' )
+ BIGNUM = ONE / SMLNUM
+ CALL SLABAD( SMLNUM, BIGNUM )
+*
+* Scale A, B if max element outside range [SMLNUM,BIGNUM]
+*
+ ANRM = CLANGE( 'M', M, N, A, LDA, RWORK )
+ IASCL = 0
+ IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
+*
+* Scale matrix norm up to SMLNUM
+*
+ CALL CLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, INFO )
+ IASCL = 1
+ ELSE IF( ANRM.GT.BIGNUM ) THEN
+*
+* Scale matrix norm down to BIGNUM
+*
+ CALL CLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, INFO )
+ IASCL = 2
+ ELSE IF( ANRM.EQ.ZERO ) THEN
+*
+* Matrix all zero. Return zero solution.
+*
+ CALL CLASET( 'F', MAXMN, NRHS, CZERO, CZERO, B, LDB )
+ GO TO 50
+ END IF
+*
+ BROW = M
+ IF ( TRAN ) THEN
+ BROW = N
+ END IF
+ BNRM = CLANGE( 'M', BROW, NRHS, B, LDB, RWORK )
+ IBSCL = 0
+ IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
+*
+* Scale matrix norm up to SMLNUM
+*
+ CALL CLASCL( 'G', 0, 0, BNRM, SMLNUM, BROW, NRHS, B, LDB,
+ $ INFO )
+ IBSCL = 1
+ ELSE IF( BNRM.GT.BIGNUM ) THEN
+*
+* Scale matrix norm down to BIGNUM
+*
+ CALL CLASCL( 'G', 0, 0, BNRM, BIGNUM, BROW, NRHS, B, LDB,
+ $ INFO )
+ IBSCL = 2
+ END IF
+*
+ IF ( M.GE.N) THEN
+*
+* compute QR factorization of A
+*
+ CALL CGEQR( M, N, A, LDA, WORK(LW2+1), LW1
+ $ , WORK(1), LW2, INFO )
+ IF (.NOT.TRAN) THEN
+*
+* Least-Squares Problem min || A * X - B ||
+*
+* B(1:M,1:NRHS) := Q**T * B(1:M,1:NRHS)
+*
+ CALL CGEMQR( 'L' , 'C', 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 CTRTRS( 'U', 'N', 'N', N, NRHS,
+ $ A, LDA, B, LDB, INFO )
+ IF(INFO.GT.0) THEN
+ RETURN
+ END IF
+ SCLLEN = N
+ ELSE
+*
+* Overdetermined system of equations A**T * X = B
+*
+* B(1:N,1:NRHS) := inv(R**T) * B(1:N,1:NRHS)
+*
+ CALL CTRTRS( 'U', 'C', 'N', N, NRHS,
+ $ A, LDA, B, LDB, INFO )
+*
+ IF( INFO.GT.0 ) THEN
+ RETURN
+ END IF
+*
+* B(N+1:M,1:NRHS) = CZERO
+*
+ DO 20 J = 1, NRHS
+ DO 10 I = N + 1, M
+ B( I, J ) = CZERO
+ 10 CONTINUE
+ 20 CONTINUE
+*
+* B(1:M,1:NRHS) := Q(1:N,:) * B(1:N,1:NRHS)
+*
+ CALL CGEMQR( 'L', 'N', M, NRHS, N, A, LDA,
+ $ WORK( LW2+1), LW1, B, LDB, WORK( 1 ), LW2,
+ $ INFO )
+*
+ SCLLEN = M
+*
+ END IF
+*
+ ELSE
+*
+* Compute LQ factorization of A
+*
+ CALL CGELQ( M, N, A, LDA, WORK(LW2+1), LW1
+ $ , WORK(1), LW2, INFO )
+*
+* workspace at least M, optimally M*NB.
+*
+ IF( .NOT.TRAN ) THEN
+*
+* underdetermined system of equations A * X = B
+*
+* B(1:M,1:NRHS) := inv(L) * B(1:M,1:NRHS)
+*
+ CALL CTRTRS( 'L', 'N', 'N', M, NRHS,
+ $ A, LDA, B, LDB, INFO )
+*
+ IF( INFO.GT.0 ) THEN
+ RETURN
+ END IF
+*
+* B(M+1:N,1:NRHS) = 0
+*
+ DO 40 J = 1, NRHS
+ DO 30 I = M + 1, N
+ B( I, J ) = CZERO
+ 30 CONTINUE
+ 40 CONTINUE
+*
+* B(1:N,1:NRHS) := Q(1:N,:)**T * B(1:M,1:NRHS)
+*
+ CALL CGEMLQ( 'L', 'C', N, NRHS, M, A, LDA,
+ $ WORK( LW2+1), LW1, B, LDB, WORK( 1 ), LW2,
+ $ INFO )
+*
+* workspace at least NRHS, optimally NRHS*NB
+*
+ SCLLEN = N
+*
+ ELSE
+*
+* overdetermined system min || A**T * X - B ||
+*
+* B(1:N,1:NRHS) := Q * B(1:N,1:NRHS)
+*
+ CALL CGEMLQ( 'L', 'N', N, NRHS, M, A, LDA,
+ $ WORK( LW2+1), LW1, B, LDB, WORK( 1 ), LW2,
+ $ INFO )
+*
+* workspace at least NRHS, optimally NRHS*NB
+*
+* B(1:M,1:NRHS) := inv(L**T) * B(1:M,1:NRHS)
+*
+ CALL CTRTRS( 'L', 'C', 'N', M, NRHS,
+ $ A, LDA, B, LDB, INFO )
+*
+ IF( INFO.GT.0 ) THEN
+ RETURN
+ END IF
+*
+ SCLLEN = M
+*
+ END IF
+*
+ END IF
+*
+* Undo scaling
+*
+ IF( IASCL.EQ.1 ) THEN
+ CALL CLASCL( 'G', 0, 0, ANRM, SMLNUM, SCLLEN, NRHS, B, LDB,
+ $ INFO )
+ ELSE IF( IASCL.EQ.2 ) THEN
+ CALL CLASCL( 'G', 0, 0, ANRM, BIGNUM, SCLLEN, NRHS, B, LDB,
+ $ INFO )
+ END IF
+ IF( IBSCL.EQ.1 ) THEN
+ CALL CLASCL( 'G', 0, 0, SMLNUM, BNRM, SCLLEN, NRHS, B, LDB,
+ $ INFO )
+ ELSE IF( IBSCL.EQ.2 ) THEN
+ CALL CLASCL( 'G', 0, 0, BIGNUM, BNRM, SCLLEN, NRHS, B, LDB,
+ $ INFO )
+ END IF
+*
+ 50 CONTINUE
+ WORK( 1 ) = REAL( WSIZEO )
+ WORK( 2 ) = REAL( WSIZEM )
+ RETURN
+*
+* End of CGETSLS
+*
+ END
\ No newline at end of file
--- /dev/null
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE CLAMSWLQ( SIDE, TRANS, M, N, K, MB, NB, A, LDA, T,
+* $ LDT, C, LDC, WORK, LWORK, INFO )
+*
+*
+* .. Scalar Arguments ..
+* CHARACTER SIDE, TRANS
+* INTEGER INFO, LDA, M, N, K, MB, NB, LDT, LWORK, LDC
+* ..
+* .. Array Arguments ..
+* COMPLEX A( LDA, * ), WORK( * ), C(LDC, * ),
+* $ T( LDT, * )
+*> \par Purpose:
+* =============
+*>
+*> \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
+*> factorization (CLASWLQ)
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] SIDE
+*> SIDE is CHARACTER*1
+*> = 'L': apply Q or Q**T from the Left;
+*> = 'R': apply Q or Q**T from the Right.
+*>
+*> \param[in] TRANS
+*> TRANS is CHARACTER*1
+*> = 'N': No transpose, apply Q;
+*> = 'T': Transpose, apply Q**T.
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows of the matrix A. M >=0.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of columns of the matrix C. N >= M.
+*> \endverbatim
+*>
+*> \param[in] K
+*> \verbatim
+*> K is INTEGER
+*> The number of elementary reflectors whose product defines
+*> the matrix Q.
+*> M >= K >= 0;
+*>
+*> \endverbatim
+*> \param[in] MB
+*> \verbatim
+*> MB is INTEGER
+*> 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.
+*> NB > M.
+*> \endverbatim
+*>
+*> \param[in] NB
+*> \verbatim
+*> NB is INTEGER
+*> The block size to be used in the blocked QR.
+*> MB > M.
+*>
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is COMPLEX array, dimension (LDA,K)
+*> The i-th row must contain the vector which defines the blocked
+*> elementary reflector H(i), for i = 1,2,...,k, as returned by
+*> DLASWLQ in the first k rows of its array argument A.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A.
+*> If SIDE = 'L', LDA >= max(1,M);
+*> if SIDE = 'R', LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in] T
+*> \verbatim
+*> 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
+*> for further details.
+*> \endverbatim
+*>
+*> \param[in] LDT
+*> \verbatim
+*> LDT is INTEGER
+*> The leading dimension of the array T. LDT >= MB.
+*> \endverbatim
+*>
+*> \param[in,out] C
+*> C is COMPLEX array, dimension (LDC,N)
+*> On entry, the M-by-N matrix C.
+*> On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.
+*> \param[in] LDC
+*> LDC is INTEGER
+*> The leading dimension of the array C. LDC >= max(1,M).
+*>
+*> \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,NB) * MB;
+*> if SIDE = 'R', LWORK >= max(1,M) * MB.
+*> If LWORK = -1, then a workspace query is assumed; the routine
+*> only calculates the optimal size of the WORK array, returns
+*> this value as the first entry of the WORK array, and no error
+*> message related to LWORK is issued by XERBLA.
+*>
+*> \endverbatim
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> < 0: if INFO = -i, the i-th argument had an illegal value
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*> Short-Wide LQ (SWLQ) performs LQ by a sequence of orthogonal transformations,
+*> representing Q as a product of other orthogonal matrices
+*> Q = Q(1) * Q(2) * . . . * Q(k)
+*> where each Q(i) zeros out upper diagonal entries of a block of NB rows of A:
+*> Q(1) zeros out the upper diagonal entries of rows 1:NB of A
+*> Q(2) zeros out the bottom MB-N rows of rows [1:M,NB+1:2*NB-M] of A
+*> Q(3) zeros out the bottom MB-N rows of rows [1:M,2*NB-M+1:3*NB-2*M] of A
+*> . . .
+*>
+*> Q(1) is computed by GELQT, which represents Q(1) by Householder vectors
+*> stored under the diagonal of rows 1:MB of A, and by upper triangular
+*> block reflectors, stored in array T(1:LDT,1:N).
+*> For more information see Further Details in GELQT.
+*>
+*> Q(i) for i>1 is computed by TPLQT, which represents Q(i) by Householder vectors
+*> stored in columns [(i-1)*(NB-M)+M+1:i*(NB-M)+M] of A, and by upper triangular
+*> 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].
+*>
+*> [1] “Communication-Optimal Parallel and Sequential QR and LU Factorizations,”
+*> J. Demmel, L. Grigori, M. Hoemmen, J. Langou,
+*> SIAM J. Sci. Comput, vol. 34, no. 1, 2012
+*> \endverbatim
+*>
+* =====================================================================
+ 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) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2013
+*
+* .. Scalar Arguments ..
+ CHARACTER SIDE, TRANS
+ INTEGER INFO, LDA, M, N, K, MB, NB, LDT, LWORK, LDC
+* ..
+* .. Array Arguments ..
+ COMPLEX A( LDA, * ), WORK( * ), C(LDC, * ),
+ $ T( LDT, * )
+* ..
+*
+* =====================================================================
+*
+* ..
+* .. Local Scalars ..
+ LOGICAL LEFT, RIGHT, TRAN, NOTRAN, LQUERY
+ INTEGER I, II, KK, LW , CTR
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* .. External Subroutines ..
+ EXTERNAL CTPMLQT, CGEMLQT, XERBLA
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ LQUERY = LWORK.LT.0
+ NOTRAN = LSAME( TRANS, 'N' )
+ TRAN = LSAME( TRANS, 'C' )
+ LEFT = LSAME( SIDE, 'L' )
+ RIGHT = LSAME( SIDE, 'R' )
+ IF (LEFT) THEN
+ LW = N * MB
+ ELSE
+ LW = M * MB
+ END IF
+*
+ INFO = 0
+ IF( .NOT.LEFT .AND. .NOT.RIGHT ) THEN
+ INFO = -1
+ ELSE IF( .NOT.TRAN .AND. .NOT.NOTRAN ) THEN
+ INFO = -2
+ ELSE IF( M.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( K.LT.0 ) THEN
+ INFO = -5
+ ELSE IF( LDA.LT.MAX( 1, K ) ) THEN
+ INFO = -9
+ ELSE IF( LDT.LT.MAX( 1, MB) ) THEN
+ INFO = -11
+ ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
+ INFO = -13
+ ELSE IF(( LWORK.LT.MAX(1,LW)).AND.(.NOT.LQUERY)) THEN
+ INFO = -15
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'CLAMSWLQ', -INFO )
+ WORK(1) = LW
+ RETURN
+ ELSE IF (LQUERY) THEN
+ WORK(1) = LW
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( MIN(M,N,K).EQ.0 ) THEN
+ RETURN
+ 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)
+ RETURN
+ END IF
+*
+ IF(LEFT.AND.TRAN) THEN
+*
+* Multiply Q to the last block of C
+*
+ KK = MOD((M-K),(NB-K))
+ CTR = (M-K)/(NB-K)
+ IF (KK.GT.0) THEN
+ II=M-KK+1
+ CALL CTPMLQT('L','C',KK , N, K, 0, MB, A(1,II), LDA,
+ $ T(1,CTR*K+1), LDT, C(1,1), LDC,
+ $ C(II,1), LDC, WORK, INFO )
+ ELSE
+ II=M+1
+ END IF
+*
+ DO I=II-(NB-K),NB+1,-(NB-K)
+*
+* Multiply Q to the current block of C (1:M,I:I+NB)
+*
+ CTR = CTR - 1
+ CALL CTPMLQT('L','C',NB-K , N, K, 0,MB, A(1,I), 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:M,1:NB)
+*
+ CALL CGEMLQT('L','C',NB , N, K, MB, A(1,1), LDA, T
+ $ ,LDT ,C(1,1), LDC, WORK, INFO )
+*
+ ELSE IF (LEFT.AND.NOTRAN) THEN
+*
+* Multiply Q to the first block of C
+*
+ KK = MOD((M-K),(NB-K))
+ II = M-KK+1
+ CTR = 1
+ CALL CGEMLQT('L','N',NB , N, K, MB, A(1,1), LDA, T
+ $ ,LDT ,C(1,1), LDC, WORK, INFO )
+*
+ DO I=NB+1,II-NB+K,(NB-K)
+*
+* Multiply Q to the current block of C (I:I+NB,1:N)
+*
+ CALL CTPMLQT('L','N',NB-K , N, K, 0,MB, A(1,I), LDA,
+ $ T(1, CTR *K+1), LDT, C(1,1), LDC,
+ $ C(I,1), LDC, WORK, INFO )
+ CTR = CTR + 1
+*
+ END DO
+ IF(II.LE.M) THEN
+*
+* Multiply Q to the last block of C
+*
+ CALL CTPMLQT('L','N',KK , N, K, 0, MB, A(1,II), LDA,
+ $ T(1, CTR*K+1), LDT, C(1,1), LDC,
+ $ C(II,1), LDC, WORK, INFO )
+*
+ END IF
+*
+ ELSE IF(RIGHT.AND.NOTRAN) THEN
+*
+* Multiply Q to the last block of C
+*
+ KK = MOD((N-K),(NB-K))
+ CTR = (N-K)/(NB-K)
+ IF (KK.GT.0) THEN
+ II=N-KK+1
+ CALL CTPMLQT('R','N',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 )
+ ELSE
+ II=N+1
+ END IF
+*
+ DO I=II-(NB-K),NB+1,-(NB-K)
+*
+* Multiply Q to the current block of C (1:M,I:I+MB)
+*
+ CTR = CTR - 1
+ CALL CTPMLQT('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 )
+ END DO
+*
+* Multiply Q to the first block of C (1:M,1:MB)
+*
+ CALL CGEMLQT('R','N',M , NB, K, MB, A(1,1), LDA, T
+ $ ,LDT ,C(1,1), LDC, WORK, INFO )
+*
+ ELSE IF (RIGHT.AND.TRAN) THEN
+*
+* Multiply Q to the first block of C
+*
+ KK = MOD((N-K),(NB-K))
+ II=N-KK+1
+ CTR = 1
+ CALL CGEMLQT('R','C',M , NB, K, MB, A(1,1), LDA, T
+ $ ,LDT ,C(1,1), LDC, WORK, INFO )
+*
+ DO I=NB+1,II-NB+K,(NB-K)
+*
+* Multiply Q to the current block of C (1:M,I:I+MB)
+*
+ CALL CTPMLQT('R','C',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 )
+ CTR = CTR + 1
+*
+ END DO
+ 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 IF
+*
+ END IF
+*
+ WORK(1) = LW
+ RETURN
+*
+* End of CLAMSWLQ
+*
+ END
\ No newline at end of file
--- /dev/null
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE CLAMTSQR( SIDE, TRANS, M, N, K, MB, NB, A, LDA, T,
+* $ LDT, C, LDC, WORK, LWORK, INFO )
+*
+*
+* .. Scalar Arguments ..
+* CHARACTER SIDE, TRANS
+* INTEGER INFO, LDA, M, N, K, MB, NB, LDT, LWORK, LDC
+* ..
+* .. Array Arguments ..
+* COMPLEX A( LDA, * ), WORK( * ), C(LDC, * ),
+* $ T( LDT, * )
+*> \par Purpose:
+* =============
+*>
+*> \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
+*> QR factorization (CLATSQR)
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] SIDE
+*> SIDE is CHARACTER*1
+*> = 'L': apply Q or Q**T from the Left;
+*> = 'R': apply Q or Q**T from the Right.
+*>
+*> \param[in] TRANS
+*> TRANS is CHARACTER*1
+*> = 'N': No transpose, apply Q;
+*> = 'C': Conjugate Transpose, apply Q**C.
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows of the matrix A. M >=0.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of columns of the matrix C. M >= N >= 0.
+*> \endverbatim
+*>
+*> \param[in] K
+*> \verbatim
+*> K is INTEGER
+*> The number of elementary reflectors whose product defines
+*> the matrix Q.
+*> N >= K >= 0;
+*>
+*> \endverbatim
+*>
+*> \param[in] MB
+*> \verbatim
+*> MB is INTEGER
+*> 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.
+*> 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
+*> its array argument A.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A.
+*> If SIDE = 'L', LDA >= max(1,M);
+*> if SIDE = 'R', LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in] T
+*> \verbatim
+*> 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
+*> for further details.
+*> \endverbatim
+*>
+*> \param[in] LDT
+*> \verbatim
+*> LDT is INTEGER
+*> The leading dimension of the array T. LDT >= NB.
+*> \endverbatim
+*>
+*> \param[in,out] C
+*> C is COMPLEX array, dimension (LDC,N)
+*> On entry, the M-by-N matrix C.
+*> On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.
+*> \param[in] LDC
+*> LDC is INTEGER
+*> The leading dimension of the array C. LDC >= max(1,M).
+*>
+*> \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
+*> only calculates the optimal size of the WORK array, returns
+*> this value as the first entry of the WORK array, and no error
+*> message related to LWORK is issued by XERBLA.
+*>
+*> \endverbatim
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> < 0: if INFO = -i, the i-th argument had an illegal value
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*> Tall-Skinny QR (TSQR) performs QR by a sequence of orthogonal transformations,
+*> representing Q as a product of other orthogonal matrices
+*> Q = Q(1) * Q(2) * . . . * Q(k)
+*> where each Q(i) zeros out subdiagonal entries of a block of MB rows of A:
+*> Q(1) zeros out the subdiagonal entries of rows 1:MB of A
+*> Q(2) zeros out the bottom MB-N rows of rows [1:N,MB+1:2*MB-N] of A
+*> Q(3) zeros out the bottom MB-N rows of rows [1:N,2*MB-N+1:3*MB-2*N] of A
+*> . . .
+*>
+*> Q(1) is computed by GEQRT, which represents Q(1) by Householder vectors
+*> stored under the diagonal of rows 1:MB of A, and by upper triangular
+*> block reflectors, stored in array T(1:LDT,1:N).
+*> For more information see Further Details in GEQRT.
+*>
+*> Q(i) for i>1 is computed by TPQRT, which represents Q(i) by Householder vectors
+*> stored in rows [(i-1)*(MB-N)+N+1:i*(MB-N)+N] of A, and by upper triangular
+*> 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].
+*>
+*> [1] “Communication-Optimal Parallel and Sequential QR and LU Factorizations,”
+*> J. Demmel, L. Grigori, M. Hoemmen, J. Langou,
+*> SIAM J. Sci. Comput, vol. 34, no. 1, 2012
+*> \endverbatim
+*>
+* =====================================================================
+ 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) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2013
+*
+* .. Scalar Arguments ..
+ CHARACTER SIDE, TRANS
+ INTEGER INFO, LDA, M, N, K, MB, NB, LDT, LWORK, LDC
+* ..
+* .. Array Arguments ..
+ COMPLEX A( LDA, * ), WORK( * ), C(LDC, * ),
+ $ T( LDT, * )
+* ..
+*
+* =====================================================================
+*
+* ..
+* .. Local Scalars ..
+ LOGICAL LEFT, RIGHT, TRAN, NOTRAN, LQUERY
+ INTEGER I, II, KK, LW, CTR
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* .. External Subroutines ..
+ EXTERNAL CGEMQRT, CTPMQRT, XERBLA
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ LQUERY = LWORK.LT.0
+ NOTRAN = LSAME( TRANS, 'N' )
+ TRAN = LSAME( TRANS, 'C' )
+ LEFT = LSAME( SIDE, 'L' )
+ RIGHT = LSAME( SIDE, 'R' )
+ IF (LEFT) THEN
+ LW = N * NB
+ ELSE
+ LW = M * NB
+ END IF
+*
+ INFO = 0
+ IF( .NOT.LEFT .AND. .NOT.RIGHT ) THEN
+ INFO = -1
+ ELSE IF( .NOT.TRAN .AND. .NOT.NOTRAN ) THEN
+ INFO = -2
+ ELSE IF( M.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( K.LT.0 ) THEN
+ INFO = -5
+ ELSE IF( LDA.LT.MAX( 1, K ) ) THEN
+ INFO = -9
+ ELSE IF( LDT.LT.MAX( 1, NB) ) THEN
+ INFO = -11
+ ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
+ INFO = -13
+ ELSE IF(( LWORK.LT.MAX(1,LW)).AND.(.NOT.LQUERY)) THEN
+ INFO = -15
+ END IF
+ 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( INFO.NE.0 ) THEN
+ CALL XERBLA( 'CLAMTSQR', -INFO )
+ RETURN
+ ELSE IF (LQUERY) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( MIN(M,N,K).EQ.0 ) THEN
+ RETURN
+ 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)
+ RETURN
+ END IF
+*
+ IF(LEFT.AND.NOTRAN) THEN
+*
+* Multiply Q to the last block of C
+*
+ KK = MOD((M-K),(MB-K))
+ CTR = (M-K)/(MB-K)
+ IF (KK.GT.0) THEN
+ II=M-KK+1
+ CALL CTPMQRT('L','N',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 )
+ ELSE
+ II=M+1
+ END IF
+*
+ DO I=II-(MB-K),MB+1,-(MB-K)
+*
+* Multiply Q to the current block of C (I:I+MB,1:N)
+*
+ CTR = CTR - 1
+ CALL CTPMQRT('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)
+*
+ CALL CGEMQRT('L','N',MB , N, K, NB, A(1,1), LDA, T
+ $ ,LDT ,C(1,1), LDC, WORK, INFO )
+*
+ ELSE IF (LEFT.AND.TRAN) THEN
+*
+* Multiply Q to the first block of C
+*
+ KK = MOD((M-K),(MB-K))
+ II=M-KK+1
+ CTR = 1
+ CALL CGEMQRT('L','C',MB , N, K, NB, A(1,1), LDA, T
+ $ ,LDT ,C(1,1), LDC, WORK, INFO )
+*
+ DO I=MB+1,II-MB+K,(MB-K)
+*
+* Multiply Q to the current block of C (I:I+MB,1:N)
+*
+ CALL CTPMQRT('L','C',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 )
+ CTR = CTR + 1
+*
+ END DO
+ 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 )
+*
+ END IF
+*
+ ELSE IF(RIGHT.AND.TRAN) THEN
+*
+* Multiply Q to the last block of C
+*
+ KK = MOD((N-K),(MB-K))
+ CTR = (N-K)/(MB-K)
+ IF (KK.GT.0) THEN
+ II=N-KK+1
+ CALL CTPMQRT('R','C',M , KK, K, 0, NB, A(II,1), LDA,
+ $ T(1, CTR*K+1), LDT, C(1,1), LDC,
+ $ C(1,II), LDC, WORK, INFO )
+ ELSE
+ II=N+1
+ END IF
+*
+ DO I=II-(MB-K),MB+1,-(MB-K)
+*
+* Multiply Q to the current block of C (1:M,I:I+MB)
+*
+ CTR = CTR - 1
+ CALL CTPMQRT('R','C',M , MB-K, K, 0,NB, A(I,1), LDA,
+ $ T(1,CTR*K+1), LDT, C(1,1), LDC,
+ $ C(1,I), LDC, WORK, INFO )
+ END DO
+*
+* Multiply Q to the first block of C (1:M,1:MB)
+*
+ CALL CGEMQRT('R','C',M , MB, K, NB, A(1,1), LDA, T
+ $ ,LDT ,C(1,1), LDC, WORK, INFO )
+*
+ ELSE IF (RIGHT.AND.NOTRAN) THEN
+*
+* Multiply Q to the first block of C
+*
+ KK = MOD((N-K),(MB-K))
+ II=N-KK+1
+ CTR = 1
+ CALL CGEMQRT('R','N', M, MB , K, NB, A(1,1), LDA, T
+ $ ,LDT ,C(1,1), LDC, WORK, INFO )
+*
+ DO I=MB+1,II-MB+K,(MB-K)
+*
+* Multiply Q to the current block of C (1:M,I:I+MB)
+*
+ CALL CTPMQRT('R','N', M, MB-K, K, 0,NB, A(I,1), LDA,
+ $ T(1,CTR*K+1),LDT, C(1,1), LDC,
+ $ C(1,I), LDC, WORK, INFO )
+ CTR = CTR + 1
+*
+ END DO
+ IF(II.LE.N) THEN
+*
+* Multiply Q to the last block of C
+*
+ CALL CTPMQRT('R','N', M, KK , K, 0,NB, A(II,1), LDA,
+ $ T(1,CTR*K+1),LDT, C(1,1), LDC,
+ $ C(1,II), LDC, WORK, INFO )
+*
+ END IF
+*
+ END IF
+*
+ IF(LEFT) THEN
+ WORK(1)= N * NB
+ ELSE IF(RIGHT) THEN
+ WORK(1)= MB * NB
+ END IF
+ RETURN
+*
+* End of CLAMTSQR
+*
+ END
\ No newline at end of file
--- /dev/null
+*
+* 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
+*> M-by-N matrix A, where N >= M:
+*> A = L * Q
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows of the matrix A. M >= 0.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of columns of the matrix A. N >= M >= 0.
+*> \endverbatim
+*>
+*> \param[in] MB
+*> \verbatim
+*> MB is INTEGER
+*> 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.
+*> NB > M.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \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
+*> of blocked V (see Further Details).
+*>
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,M).
+*> \endverbatim
+*>
+*> \param[out] T
+*> \verbatim
+*> 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.
+*> See Further Details below.
+*> \endverbatim
+*>
+*> \param[in] LDT
+*> \verbatim
+*> LDT is INTEGER
+*> The leading dimension of the array T. LDT >= MB.
+*> \endverbatim
+*>
+*>
+*> \param[out] WORK
+*> \verbatim
+*> (workspace) COMPLEX array, dimension (MAX(1,LWORK))
+*>
+*> \endverbatim
+*> \param[in] LWORK
+*> \verbatim
+*> The dimension of the array WORK. LWORK >= MB*M.
+*> If LWORK = -1, then a workspace query is assumed; the routine
+*> only calculates the optimal size of the WORK array, returns
+*> this value as the first entry of the WORK array, and no error
+*> message related to LWORK is issued by XERBLA.
+*>
+*> \endverbatim
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> < 0: if INFO = -i, the i-th argument had an illegal value
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*> Short-Wide LQ (SWLQ) performs LQ by a sequence of orthogonal transformations,
+*> representing Q as a product of other orthogonal matrices
+*> Q = Q(1) * Q(2) * . . . * Q(k)
+*> where each Q(i) zeros out upper diagonal entries of a block of NB rows of A:
+*> Q(1) zeros out the upper diagonal entries of rows 1:NB of A
+*> Q(2) zeros out the bottom MB-N rows of rows [1:M,NB+1:2*NB-M] of A
+*> Q(3) zeros out the bottom MB-N rows of rows [1:M,2*NB-M+1:3*NB-2*M] of A
+*> . . .
+*>
+*> Q(1) is computed by GELQT, which represents Q(1) by Householder vectors
+*> stored under the diagonal of rows 1:MB of A, and by upper triangular
+*> block reflectors, stored in array T(1:LDT,1:N).
+*> For more information see Further Details in GELQT.
+*>
+*> Q(i) for i>1 is computed by TPLQT, which represents Q(i) by Householder vectors
+*> stored in columns [(i-1)*(NB-M)+M+1:i*(NB-M)+M] of A, and by upper triangular
+*> 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].
+*>
+*> [1] “Communication-Optimal Parallel and Sequential QR and LU Factorizations,”
+*> J. Demmel, L. Grigori, M. Hoemmen, J. Langou,
+*> SIAM J. Sci. Comput, vol. 34, no. 1, 2012
+*> \endverbatim
+*>
+* =====================================================================
+ SUBROUTINE CLASWLQ( M, N, MB, NB, A, LDA, T, LDT, WORK, LWORK,
+ $ INFO)
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd. --
+* November 2013
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, M, N, MB, NB, LWORK, LDT
+* ..
+* .. Array Arguments ..
+ COMPLEX A( LDA, * ), WORK( * ), T( LDT, *)
+* ..
+*
+* =====================================================================
+*
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY
+ INTEGER I, II, KK, CTR
+* ..
+* .. EXTERNAL FUNCTIONS ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* .. EXTERNAL SUBROUTINES ..
+ EXTERNAL CGELQT, CTPLQT, XERBLA
+* .. INTRINSIC FUNCTIONS ..
+ INTRINSIC MAX, MIN, MOD
+* ..
+* .. EXTERNAL FUNCTIONS ..
+ INTEGER ILAENV
+ EXTERNAL ILAENV
+* ..
+* .. EXECUTABLE STATEMENTS ..
+*
+* TEST THE INPUT ARGUMENTS
+*
+ INFO = 0
+*
+ LQUERY = ( LWORK.EQ.-1 )
+*
+ IF( M.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 .OR. N.LT.M ) THEN
+ INFO = -2
+ ELSE IF( MB.LT.1 .OR. ( MB.GT.M .AND. M.GT.0 )) THEN
+ INFO = -3
+ ELSE IF( NB.LE.M ) THEN
+ INFO = -4
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -5
+ 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
+ WORK(1) = MB*M
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'CLASWLQ', -INFO )
+ RETURN
+ ELSE IF (LQUERY) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( MIN(M,N).EQ.0 ) THEN
+ RETURN
+ END IF
+*
+* The LQ Decomposition
+*
+ 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
+*
+ KK = MOD((N-M),(NB-M))
+ II=N-KK+1
+*
+* Compute the LQ factorization of the first block A(1:M,1:NB)
+*
+ CALL CGELQT( M, NB, MB, A(1,1), LDA, T, LDT, WORK, INFO)
+ 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 ),
+ $ LDA, T(1,CTR*M+1),
+ $ LDT, WORK, INFO )
+ CTR = CTR + 1
+ END DO
+*
+* Compute the QR factorization of the last block A(1:M,II:N)
+*
+ IF (II.LE.N) THEN
+ CALL CTPLQT( M, KK, 0, MB, A(1,1), LDA, A( 1, II ),
+ $ LDA, T(1,CTR*M+1), LDT,
+ $ WORK, INFO )
+ END IF
+*
+ WORK( 1 ) = M * MB
+ RETURN
+*
+* End of CLASWLQ
+*
+ END
\ No newline at end of file
--- /dev/null
+*
+* Definition:
+* ===========
+*
+* 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
+*> an M-by-N matrix A, where M >= N:
+*> A = Q * R .
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows of the matrix A. M >= 0.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of columns of the matrix A. M >= N >= 0.
+*> \endverbatim
+*>
+*> \param[in] MB
+*> \verbatim
+*> MB is INTEGER
+*> 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.
+*> N >= NB >= 1.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \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
+*> of blocked V (see Further Details).
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,M).
+*> \endverbatim
+*>
+*> \param[out] T
+*> \verbatim
+*> 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.
+*> See Further Details below.
+*> \endverbatim
+*>
+*> \param[in] LDT
+*> \verbatim
+*> LDT is INTEGER
+*> The leading dimension of the array T. LDT >= NB.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> (workspace) COMPLEX array, dimension (MAX(1,LWORK))
+*> \endverbatim
+*>
+*> \param[in] LWORK
+*> \verbatim
+*> The dimension of the array WORK. LWORK >= NB*N.
+*> If LWORK = -1, then a workspace query is assumed; the routine
+*> only calculates the optimal size of the WORK array, returns
+*> this value as the first entry of the WORK array, and no error
+*> message related to LWORK is issued by XERBLA.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> < 0: if INFO = -i, the i-th argument had an illegal value
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*> Tall-Skinny QR (TSQR) performs QR by a sequence of orthogonal transformations,
+*> representing Q as a product of other orthogonal matrices
+*> Q = Q(1) * Q(2) * . . . * Q(k)
+*> where each Q(i) zeros out subdiagonal entries of a block of MB rows of A:
+*> Q(1) zeros out the subdiagonal entries of rows 1:MB of A
+*> Q(2) zeros out the bottom MB-N rows of rows [1:N,MB+1:2*MB-N] of A
+*> Q(3) zeros out the bottom MB-N rows of rows [1:N,2*MB-N+1:3*MB-2*N] of A
+*> . . .
+*>
+*> Q(1) is computed by GEQRT, which represents Q(1) by Householder vectors
+*> stored under the diagonal of rows 1:MB of A, and by upper triangular
+*> block reflectors, stored in array T(1:LDT,1:N).
+*> For more information see Further Details in GEQRT.
+*>
+*> Q(i) for i>1 is computed by TPQRT, which represents Q(i) by Householder vectors
+*> stored in rows [(i-1)*(MB-N)+N+1:i*(MB-N)+N] of A, and by upper triangular
+*> 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].
+*>
+*> [1] “Communication-Optimal Parallel and Sequential QR and LU Factorizations,”
+*> J. Demmel, L. Grigori, M. Hoemmen, J. Langou,
+*> SIAM J. Sci. Comput, vol. 34, no. 1, 2012
+*> \endverbatim
+*>
+* =====================================================================
+ SUBROUTINE CLATSQR( M, N, MB, NB, A, LDA, T, LDT, WORK,
+ $ LWORK, INFO)
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd. --
+* November 2013
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, M, N, MB, NB, LDT, LWORK
+* ..
+* .. Array Arguments ..
+ COMPLEX A( LDA, * ), WORK( * ), T(LDT, *)
+* ..
+*
+* =====================================================================
+*
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY
+ INTEGER I, II, KK, CTR
+* ..
+* .. EXTERNAL FUNCTIONS ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* .. EXTERNAL SUBROUTINES ..
+ EXTERNAL CGEQRT, CTPQRT, XERBLA
+* .. INTRINSIC FUNCTIONS ..
+ INTRINSIC MAX, MIN, MOD
+* ..
+* .. EXECUTABLE STATEMENTS ..
+*
+* TEST THE INPUT ARGUMENTS
+*
+ INFO = 0
+*
+ LQUERY = ( LWORK.EQ.-1 )
+*
+ IF( M.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 .OR. M.LT.N ) THEN
+ INFO = -2
+ ELSE IF( MB.LE.N ) THEN
+ 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
+ INFO = -5
+ ELSE IF( LDT.LT.NB ) THEN
+ INFO = -8
+ ELSE IF( LWORK.LT.(N*NB) .AND. (.NOT.LQUERY) ) THEN
+ INFO = -10
+ END IF
+ IF( INFO.EQ.0) THEN
+ WORK(1) = NB*N
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'CLATSQR', -INFO )
+ RETURN
+ ELSE IF (LQUERY) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( MIN(M,N).EQ.0 ) THEN
+ RETURN
+ END IF
+*
+* The QR Decomposition
+*
+ IF ((MB.LE.N).OR.(MB.GE.M)) THEN
+ CALL CGEQRT( M, N, NB, A, LDA, T, LDT, WORK, INFO)
+ RETURN
+ END IF
+ KK = MOD((M-N),(MB-N))
+ II=M-KK+1
+*
+* Compute the QR factorization of the first block A(1:MB,1:N)
+*
+ CALL CGEQRT( MB, N, NB, A(1,1), LDA, T, LDT, WORK, INFO )
+ 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,
+ $ T(1,CTR * N + 1),
+ $ LDT, WORK, INFO )
+ CTR = CTR + 1
+ END DO
+*
+* Compute the QR factorization of the last block A(II:M,1:N)
+*
+ IF (II.LE.M) THEN
+ CALL CTPQRT( KK, N, 0, NB, A(1,1), LDA, A( II, 1 ), LDA,
+ $ T(1, CTR * N + 1), LDT,
+ $ WORK, INFO )
+ END IF
+*
+ work( 1 ) = N*NB
+ RETURN
+*
+* End of CLATSQR
+*
+ END
\ No newline at end of file
--- /dev/null
+* Definition:
+* ===========
+*
+* 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
+*> WY representation for Q.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows of the matrix B, and the order of the
+*> triangular matrix A.
+*> M >= 0.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of columns of the matrix B.
+*> N >= 0.
+*> \endverbatim
+*>
+*> \param[in] L
+*> \verbatim
+*> L is INTEGER
+*> The number of rows of the lower trapezoidal part of B.
+*> MIN(M,N) >= L >= 0. See Further Details.
+*> \endverbatim
+*>
+*> \param[in] MB
+*> \verbatim
+*> MB is INTEGER
+*> The block size to be used in the blocked QR. M >= MB >= 1.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is COMPLEX array, dimension (LDA,N)
+*> On entry, the lower triangular N-by-N matrix A.
+*> On exit, the elements on and below the diagonal of the array
+*> contain the lower triangular matrix L.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in,out] B
+*> \verbatim
+*> B is COMPLEX array, dimension (LDB,N)
+*> 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
+*>
+*> \param[in] LDB
+*> \verbatim
+*> LDB is INTEGER
+*> The leading dimension of the array B. LDB >= max(1,M).
+*> \endverbatim
+*>
+*> \param[out] T
+*> \verbatim
+*> T is COMPLEX array, dimension (LDT,N)
+*> 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
+*> The leading dimension of the array T. LDT >= MB.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is COMPLEX array, dimension (MB*M)
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> < 0: if INFO = -i, the i-th argument had an illegal value
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2013
+*
+*> \ingroup doubleOTHERcomputational
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*>
+*> 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 ]
+*> [ 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.
+*>
+*> 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 ]
+*> [ A ] <- lower triangular N-by-N
+*> [ B ] <- M-by-N pentagonal
+*>
+*> so that W can be represented as
+*> [ 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 ]
+*> [ 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 number of blocks is B = ceiling(M/MB), where each
+*> 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
+*> for the last block) T's are stored in the MB-by-N matrix T as
+*>
+*> T = [T1 T2 ... TB].
+*> \endverbatim
+*>
+* =====================================================================
+ SUBROUTINE CTPLQT( M, N, L, MB, A, LDA, B, LDB, T, LDT, WORK,
+ $ INFO )
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2013
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, LDB, LDT, N, M, L, MB
+* ..
+* .. Array Arguments ..
+ COMPLEX A( LDA, * ), B( LDB, * ), T( LDT, * ), WORK( * )
+* ..
+*
+* =====================================================================
+*
+* ..
+* .. Local Scalars ..
+ INTEGER I, IB, LB, NB, IINFO
+* ..
+* .. External Subroutines ..
+ EXTERNAL CTPLQT2, CTPRFB, XERBLA
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+ IF( M.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( L.LT.0 .OR. (L.GT.MIN(M,N) .AND. MIN(M,N).GE.0)) THEN
+ INFO = -3
+ ELSE IF( MB.LT.1 .OR. (MB.GT.M .AND. M.GT.0)) THEN
+ INFO = -4
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -6
+ ELSE IF( LDB.LT.MAX( 1, M ) ) THEN
+ INFO = -8
+ ELSE IF( LDT.LT.MB ) THEN
+ INFO = -10
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'CTPLQT', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ 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 )
+ NB = MIN( N-L+I+IB-1, N )
+ IF( I.GE.L ) THEN
+ LB = 0
+ ELSE
+ LB = NB-N+L-I+1
+ END IF
+*
+ 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,
+ $ WORK, M-I-IB+1)
+ END IF
+ END DO
+ RETURN
+*
+* End of CTPLQT
+*
+ END
--- /dev/null
+* Definition:
+* ===========
+*
+* 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,
+*> using the compact WY representation for Q.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The total number of rows of the matrix B.
+*> M >= 0.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of columns of the matrix B, and the order of
+*> the triangular matrix A.
+*> N >= 0.
+*> \endverbatim
+*>
+*> \param[in] L
+*> \verbatim
+*> L is INTEGER
+*> The number of rows of the lower trapezoidal part of B.
+*> MIN(M,N) >= L >= 0. See Further Details.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is COMPLEX array, dimension (LDA,N)
+*> On entry, the lower triangular M-by-M matrix A.
+*> On exit, the elements on and below the diagonal of the array
+*> contain the lower triangular matrix L.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in,out] B
+*> \verbatim
+*> B is COMPLEX array, dimension (LDB,N)
+*> 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
+*>
+*> \param[in] LDB
+*> \verbatim
+*> LDB is INTEGER
+*> The leading dimension of the array B. LDB >= max(1,M).
+*> \endverbatim
+*>
+*> \param[out] T
+*> \verbatim
+*> T is COMPLEX array, dimension (LDT,M)
+*> The N-by-N upper triangular factor T of the block reflector.
+*> See Further Details.
+*> \endverbatim
+*>
+*> \param[in] LDT
+*> \verbatim
+*> LDT is INTEGER
+*> The leading dimension of the array T. LDT >= max(1,M)
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> < 0: if INFO = -i, the i-th argument had an illegal value
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date September 2012
+*
+*> \ingroup doubleOTHERcomputational
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*>
+*> 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
+*> upper trapezoidal matrix B2:
+*>
+*> B = [ B1 ][ B2 ]
+*> [ B1 ] <- M-by-(N-L) rectangular
+*> [ 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.
+*>
+*> 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 ]
+*> [ A ] <- lower triangular N-by-N
+*> [ B ] <- M-by-N pentagonal
+*>
+*> so that W can be represented as
+*>
+*> 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,
+*>
+*> 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 (M+N)-by-(M+N) block reflector H is then given by
+*>
+*> H = I - W**T * T * W
+*>
+*> where W^H is the conjugate transpose of W and T is the upper triangular
+*> factor of the block reflector.
+*> \endverbatim
+*>
+* =====================================================================
+ SUBROUTINE CTPLQT2( M, N, L, A, LDA, B, LDB, T, LDT, INFO )
+*
+* -- LAPACK computational routine (version 3.4.2) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* September 2012
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, LDB, LDT, N, M, L
+* ..
+* .. Array Arguments ..
+ COMPLEX A( LDA, * ), B( LDB, * ), T( LDT, * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ COMPLEX ONE, ZERO
+ PARAMETER( ZERO = ( 0.0E+0, 0.0E+0 ),ONE = ( 1.0E+0, 0.0E+0 ) )
+* ..
+* .. Local Scalars ..
+ INTEGER I, J, P, MP, NP
+ COMPLEX ALPHA
+* ..
+* .. External Subroutines ..
+ EXTERNAL CLARFG, CGEMV, CGERC, CTRMV, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+ IF( M.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( L.LT.0 .OR. L.GT.MIN(M,N) ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -5
+ ELSE IF( LDB.LT.MAX( 1, M ) ) THEN
+ INFO = -7
+ ELSE IF( LDT.LT.MAX( 1, M ) ) THEN
+ INFO = -9
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'CTPLQT2', -INFO )
+ RETURN
+ END IF
+*
+* 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,:)
+*
+ P = N-L+MIN( L, I )
+ CALL CLARFG( P+1, A( I, I ), B( I, 1 ), LDB, T( 1, I ) )
+ T(1,I)=CONJG(T(1,I))
+ IF( I.LT.M ) THEN
+ DO J = 1, P
+ B( I, J ) = CONJG(B(I,J))
+ END DO
+*
+* W(M-I:1) := C(I+1:M,I:N) * C(I,I:N) [use W = T(M,:)]
+*
+ 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,
+ $ 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 ))
+ DO J = 1, M-I
+ A( I+J, I ) = A( I+J, I ) + ALPHA*(T( M, J ))
+ END DO
+ CALL CGERC( M-I, P, (ALPHA), T( M, 1 ), LDT,
+ $ B( I, 1 ), LDB, B( I+1, 1 ), LDB )
+ DO J = 1, P
+ B( I, J ) = CONJG(B(I,J))
+ END DO
+ END IF
+ END DO
+*
+ DO I = 2, M
+*
+* T(I,1:I-1) := C(I:I-1,1:N)**H * (alpha * C(I,I:N))
+*
+ ALPHA = -(T( 1, I ))
+ DO J = 1, I-1
+ T( I, J ) = ZERO
+ END DO
+ P = MIN( I-1, L )
+ NP = MIN( N-L+1, N )
+ MP = MIN( P+1, M )
+ DO J = 1, N-L+P
+ B(I,J)=CONJG(B(I,J))
+ END DO
+*
+* Triangular part of B2
+*
+ DO J = 1, P
+ T( I, J ) = (ALPHA*B( I, N-L+J ))
+ END DO
+ CALL CTRMV( 'L', 'N', 'N', P, B( 1, NP ), LDB,
+ $ T( I, 1 ), LDT )
+*
+* Rectangular part of B2
+*
+ 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 )
+*
+
+*
+* T(1:I-1,I) := T(1:I-1,1:I-1) * T(I,1:I-1)
+*
+ DO J = 1, I-1
+ T(I,J)=CONJG(T(I,J))
+ END DO
+ CALL CTRMV( 'L', 'C', 'N', I-1, T, LDT, T( I, 1 ), LDT )
+ DO J = 1, I-1
+ T(I,J)=CONJG(T(I,J))
+ END DO
+ DO J = 1, N-L+P
+ B(I,J)=CONJG(B(I,J))
+ END DO
+*
+* T(I,I) = tau(I)
+*
+ T( I, I ) = T( 1, I )
+ T( 1, I ) = ZERO
+ END DO
+ DO I=1,M
+ DO J= I+1,M
+ T(I,J)=(T(J,I))
+ T(J,I)=ZERO
+ END DO
+ END DO
+
+*
+* End of CTPLQT2
+*
+ END
--- /dev/null
+* Definition:
+* ===========
+*
+* 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, * ),
+* $ T( LDT, * ), WORK( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> 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
+*
+* Arguments:
+* ==========
+*
+*> \param[in] SIDE
+*> \verbatim
+*> SIDE is CHARACTER*1
+*> = 'L': apply Q or Q**C from the Left;
+*> = 'R': apply Q or Q**C from the Right.
+*> \endverbatim
+*>
+*> \param[in] TRANS
+*> \verbatim
+*> TRANS is CHARACTER*1
+*> = 'N': No transpose, apply Q;
+*> = 'C': Transpose, apply Q**C.
+*> \endverbatim
+*>
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows of the matrix B. M >= 0.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of columns of the matrix B. N >= 0.
+*> \endverbatim
+*>
+*> \param[in] K
+*> \verbatim
+*> K is INTEGER
+*> The number of elementary reflectors whose product defines
+*> the matrix Q.
+*> \endverbatim
+*>
+*> \param[in] L
+*> \verbatim
+*> L is INTEGER
+*> The order of the trapezoidal part of V.
+*> K >= L >= 0. See Further Details.
+*> \endverbatim
+*>
+*> \param[in] MB
+*> \verbatim
+*> MB is INTEGER
+*> The block size used for the storage of T. K >= MB >= 1.
+*> This must be the same value of MB used to generate T
+*> in DTPLQT.
+*> \endverbatim
+*>
+*> \param[in] V
+*> \verbatim
+*> V is COMPLEX array, dimension (LDA,K)
+*> The i-th row must contain the vector which defines the
+*> elementary reflector H(i), for i = 1,2,...,k, as returned by
+*> DTPLQT in B. See Further Details.
+*> \endverbatim
+*>
+*> \param[in] LDV
+*> \verbatim
+*> LDV is INTEGER
+*> The leading dimension of the array V.
+*> If SIDE = 'L', LDV >= max(1,M);
+*> if SIDE = 'R', LDV >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in] T
+*> \verbatim
+*> T is COMPLEX array, dimension (LDT,K)
+*> The upper triangular factors of the block reflectors
+*> as returned by DTPLQT, stored as a MB-by-K matrix.
+*> \endverbatim
+*>
+*> \param[in] LDT
+*> \verbatim
+*> LDT is INTEGER
+*> The leading dimension of the array T. LDT >= MB.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is COMPLEX array, dimension
+*> (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
+*> 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.
+*> If SIDE = 'L', LDC >= max(1,K);
+*> If SIDE = 'R', LDC >= max(1,M).
+*> \endverbatim
+*>
+*> \param[in,out] B
+*> \verbatim
+*> B is COMPLEX array, dimension (LDB,N)
+*> On entry, the M-by-N matrix B.
+*> On exit, B 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] LDB
+*> \verbatim
+*> LDB is INTEGER
+*> The leading dimension of the array B.
+*> LDB >= max(1,M).
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is COMPLEX array. The dimension of WORK is
+*> N*MB if SIDE = 'L', or M*MB if SIDE = 'R'.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> < 0: if INFO = -i, the i-th argument had an illegal value
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2015
+*
+*> \ingroup doubleOTHERcomputational
+*
+*> \par Further Details:
+* =====================
+*>
+*> \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
+*> trapezoidal block V2:
+*>
+*> V = [V1] [V2].
+*>
+*>
+*> 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 = '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.
+*>
+*> If TRANS='N' and SIDE='L', C is on exit replaced with Q * C.
+*>
+*> If TRANS='C' and SIDE='L', C is on exit replaced with Q**C * C.
+*>
+*> If TRANS='N' and SIDE='R', C is on exit replaced with C * Q.
+*>
+*> If TRANS='C' and SIDE='R', C is on exit replaced with C * Q**C.
+*> \endverbatim
+*>
+* =====================================================================
+ SUBROUTINE CTPMLQT( SIDE, TRANS, M, N, K, L, MB, V, LDV, T, LDT,
+ $ A, LDA, B, LDB, WORK, INFO )
+*
+* -- LAPACK computational routine (version 3.6.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2015
+*
+* .. 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, * ),
+ $ T( LDT, * ), WORK( * )
+* ..
+*
+* =====================================================================
+*
+* ..
+* .. Local Scalars ..
+ LOGICAL LEFT, RIGHT, TRAN, NOTRAN
+ INTEGER I, IB, NB, LB, KF, LDAQ
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL XERBLA, CTPRFB
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* .. Test the input arguments ..
+*
+ INFO = 0
+ LEFT = LSAME( SIDE, 'L' )
+ RIGHT = LSAME( SIDE, 'R' )
+ TRAN = LSAME( TRANS, 'C' )
+ NOTRAN = LSAME( TRANS, 'N' )
+*
+ IF ( LEFT ) THEN
+ LDAQ = MAX( 1, K )
+ ELSE IF ( RIGHT ) THEN
+ LDAQ = MAX( 1, M )
+ END IF
+ IF( .NOT.LEFT .AND. .NOT.RIGHT ) THEN
+ INFO = -1
+ ELSE IF( .NOT.TRAN .AND. .NOT.NOTRAN ) THEN
+ INFO = -2
+ ELSE IF( M.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( K.LT.0 ) THEN
+ INFO = -5
+ ELSE IF( L.LT.0 .OR. L.GT.K ) THEN
+ INFO = -6
+ ELSE IF( MB.LT.1 .OR. (MB.GT.K .AND. K.GT.0) ) THEN
+ INFO = -7
+ ELSE IF( LDV.LT.K ) THEN
+ INFO = -9
+ ELSE IF( LDT.LT.MB ) THEN
+ INFO = -11
+ ELSE IF( LDA.LT.LDAQ ) THEN
+ INFO = -13
+ ELSE IF( LDB.LT.MAX( 1, M ) ) THEN
+ INFO = -15
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'CTPMLQT', -INFO )
+ RETURN
+ END IF
+*
+* .. Quick return if possible ..
+*
+ IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) RETURN
+*
+ IF( LEFT .AND. NOTRAN ) THEN
+*
+ DO I = 1, K, MB
+ 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
+ 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
+ IB = MIN( MB, K-I+1 )
+ NB = MIN( N-L+I+IB-1, N )
+ IF( I.GE.L ) THEN
+ LB = 0
+ 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,
+ $ A( 1, I ), LDA, B, LDB, WORK, M )
+ END DO
+*
+ ELSE IF( LEFT .AND. TRAN ) THEN
+*
+ KF = ((K-1)/MB)*MB+1
+ DO I = KF, 1, -MB
+ 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
+ CALL CTPRFB( 'L', 'N', '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. NOTRAN ) THEN
+*
+ KF = ((K-1)/MB)*MB+1
+ DO I = KF, 1, -MB
+ IB = MIN( MB, K-I+1 )
+ NB = MIN( N-L+I+IB-1, N )
+ IF( I.GE.L ) THEN
+ LB = 0
+ ELSE
+ 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,
+ $ A( 1, I ), LDA, B, LDB, WORK, M )
+ END DO
+*
+ END IF
+*
+ RETURN
+*
+* End of CTPMLQT
+*
+ END
--- /dev/null
+*
+* Definition:
+* ===========
+*
+* 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:
+*> A = L * Q .
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows of the matrix A. M >= 0.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of columns of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is 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
+*> (L is lower triangular if M <= N);
+*> the elements above the diagonal are the rows of
+*> blocked V representing Q (see Further Details).
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,M).
+*> \endverbatim
+*>
+*> \param[out] WORK1
+*> \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
+*> 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
+*> DLASWLQ or DGELQT
+*> \endverbatim
+*>
+*> \param[in] LWORK1
+*> \verbatim
+*> LWORK1 is INTEGER
+*> The dimension of the array WORK1.
+*> 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
+*> 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
+*> 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
+*> LWORK2 = -1.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> < 0: if INFO = -i, the i-th argument had an illegal value
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*> 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 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
+*> 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
+*> Further Details in LASWLQ or GELQT.
+*> \endverbatim
+*>
+*>
+* =====================================================================
+ SUBROUTINE DGELQ( M, N, A, LDA, WORK1, LWORK1, WORK2, LWORK2,
+ $ INFO)
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd. --
+* November 2013
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, M, N, LWORK1, LWORK2
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), WORK1( * ), WORK2( * )
+* ..
+*
+* =====================================================================
+*
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY, LMINWS
+ INTEGER MB, NB, I, II, KK, MINLW1, NBLCKS
+* ..
+* .. EXTERNAL FUNCTIONS ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* .. EXTERNAL SUBROUTINES ..
+ EXTERNAL DGELQT, DLASWLQ, XERBLA
+* .. INTRINSIC FUNCTIONS ..
+ INTRINSIC MAX, MIN, MOD
+* ..
+* .. EXTERNAL FUNCTIONS ..
+ INTEGER ILAENV
+ EXTERNAL ILAENV
+* ..
+* .. EXECUTABLE STATEMENTS ..
+*
+* TEST THE INPUT ARGUMENTS
+*
+ INFO = 0
+*
+ LQUERY = ( LWORK1.EQ.-1 .OR. LWORK2.EQ.-1 )
+*
+* 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)
+ ELSE
+ MB = 1
+ NB = N
+ END IF
+ IF( MB.GT.MIN(M,N).OR.MB.LT.1) MB = 1
+ IF( NB.GT.N.OR.NB.LE.M) NB = N
+ MINLW1 = M + 5
+ IF ((NB.GT.M).AND.(N.GT.M)) THEN
+ IF(MOD(N-M, NB-M).EQ.0) THEN
+ NBLCKS = (N-M)/(NB-M)
+ ELSE
+ NBLCKS = (N-M)/(NB-M) + 1
+ END IF
+ ELSE
+ NBLCKS = 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)
+ $ .AND.(.NOT.LQUERY)) THEN
+ IF (LWORK1.LT.MAX(1,MB*M*NBLCKS+5)) THEN
+ LMINWS = .TRUE.
+ MB = 1
+ END IF
+ IF (LWORK1.LT.MAX(1,M*NBLCKS+5)) THEN
+ LMINWS = .TRUE.
+ NB = N
+ END IF
+ IF (LWORK2.LT.MB*M) THEN
+ LMINWS = .TRUE.
+ MB = 1
+ END IF
+ END IF
+*
+ IF( M.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -4
+ 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
+*
+ IF( INFO.EQ.0) THEN
+ WORK1(1) = 1
+ WORK1(2) = MB*M*NBLCKS+5
+ WORK1(3) = MINLW1
+ WORK1(4) = MB
+ WORK1(5) = NB
+ WORK2(1) = MB * M
+ WORK2(2) = M
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DGELQ', -INFO )
+ RETURN
+ ELSE IF (LQUERY) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( MIN(M,N).EQ.0 ) THEN
+ RETURN
+ END IF
+*
+* The LQ Decomposition
+*
+ 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,
+ $ LWORK2, INFO)
+ END IF
+ RETURN
+*
+* End of DGELQ
+*
+ END
\ No newline at end of file
--- /dev/null
+*> \brief \b DGELQT
+*
+* =========== DOCUMENTATION ===========
+*
+* 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">
+*> [TXT]</a>
+*> \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.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows of the matrix A. M >= 0.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of columns of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in] MB
+*> \verbatim
+*> MB is INTEGER
+*> The block size to be used in the blocked QR. MIN(M,N) >= MB >= 1.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \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 (L is
+*> lower triangular if M <= N); the elements above the diagonal
+*> are the rows of V.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,M).
+*> \endverbatim
+*>
+*> \param[out] T
+*> \verbatim
+*> T is DOUBLE PRECISION array, dimension (LDT,MIN(M,N))
+*> The upper triangular block reflectors stored in compact form
+*> as a sequence of upper triangular blocks. See below
+*> for further details.
+*> \endverbatim
+*>
+*> \param[in] LDT
+*> \verbatim
+*> LDT is INTEGER
+*> The leading dimension of the array T. LDT >= MB.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is DOUBLE PRECISION array, dimension (MB*N)
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> < 0: if INFO = -i, the i-th argument had an illegal value
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2013
+*
+*> \ingroup doubleGEcomputational
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*>
+*> The matrix V stores the elementary reflectors H(i) in the i-th column
+*> below the diagonal. For example, if M=5 and N=3, the matrix V is
+*>
+*> 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.
+*> 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
+*> 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
+*> for the last block) T's are stored in the NB-by-N matrix T as
+*>
+*> T = (T1 T2 ... TB).
+*> \endverbatim
+*>
+* =====================================================================
+ SUBROUTINE DGELQT( M, N, MB, A, LDA, T, LDT, WORK, INFO )
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2013
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, LDT, M, N, MB
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), T( LDT, * ), WORK( * )
+* ..
+*
+* =====================================================================
+*
+* ..
+* .. Local Scalars ..
+ INTEGER I, IB, IINFO, K
+* ..
+* .. External Subroutines ..
+ EXTERNAL DGEQRT2, DGEQRT3, DLARFB, XERBLA
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+ IF( M.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( MB.LT.1 .OR. ( MB.GT.MIN(M,N) .AND. MIN(M,N).GT.0 ) )THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -5
+ ELSE IF( LDT.LT.MB ) THEN
+ INFO = -7
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DGELQT', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ K = MIN( M, N )
+ IF( K.EQ.0 ) RETURN
+*
+* Blocked loop of length K
+*
+ 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+IB, I ), LDA, WORK , M-I-IB+1 )
+ END IF
+ END DO
+ RETURN
+*
+* End of DGELQT
+*
+ END
--- /dev/null
+*> \brief \b DGELQT3 recursively computes a LQ factorization of a general real or complex matrix using the compact WY representation of Q.
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download DGEQRT3 + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dgelqt3.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dgelqt3.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dgelqt3.f">
+*> [TXT]</a>
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* RECURSIVE SUBROUTINE DGELQT3( M, N, A, LDA, T, LDT, INFO )
+*
+* .. Scalar Arguments ..
+* INTEGER INFO, LDA, M, N, LDT
+* ..
+* .. Array Arguments ..
+* DOUBLE PRECISION 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.
+*>
+*> Based on the algorithm of Elmroth and Gustavson,
+*> IBM J. Res. Develop. Vol 44 No. 4 July 2000.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows of the matrix A. M =< N.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of columns of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is DOUBLE PRECISION array, dimension (LDA,N)
+*> On entry, the real M-by-N matrix A. On exit, the elements on and
+*> below the diagonal contain the N-by-N lower triangular matrix L; the
+*> elements above the diagonal are the rows of V. See below for
+*> further details.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,M).
+*> \endverbatim
+*>
+*> \param[out] T
+*> \verbatim
+*> T is DOUBLE PRECISION array, dimension (LDT,N)
+*> The N-by-N upper triangular factor of the block reflector.
+*> The elements on and above the diagonal contain the block
+*> reflector T; the elements below the diagonal are not used.
+*> See below for further details.
+*> \endverbatim
+*>
+*> \param[in] LDT
+*> \verbatim
+*> LDT is INTEGER
+*> The leading dimension of the array T. LDT >= max(1,N).
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> < 0: if INFO = -i, the i-th argument had an illegal value
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date September 2012
+*
+*> \ingroup doubleGEcomputational
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*>
+*> The matrix V stores the elementary reflectors H(i) in the i-th column
+*> below the diagonal. For example, if M=5 and N=3, the matrix V is
+*>
+*> 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
+*> block reflector H is then given by
+*>
+*> H = I - V * T * V**T
+*>
+*> where V**T is the transpose of V.
+*>
+*> For details of the algorithm, see Elmroth and Gustavson (cited above).
+*> \endverbatim
+*>
+* =====================================================================
+ RECURSIVE SUBROUTINE DGELQT3( M, N, A, LDA, T, LDT, INFO )
+*
+* -- LAPACK computational routine (version 3.4.2) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* September 2012
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, M, N, LDT
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), T( LDT, * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE
+ PARAMETER ( ONE = 1.0D+00 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, I1, J, J1, N1, N2, IINFO
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLARFG, DTRMM, DGEMM, XERBLA
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+ IF( M .LT. 0 ) THEN
+ INFO = -1
+ ELSE IF( N .LT. M ) THEN
+ INFO = -2
+ ELSE IF( LDA .LT. MAX( 1, M ) ) THEN
+ INFO = -4
+ ELSE IF( LDT .LT. MAX( 1, M ) ) THEN
+ INFO = -6
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DGELQT3', -INFO )
+ RETURN
+ END IF
+*
+ IF( M.EQ.1 ) THEN
+*
+* Compute Householder transform when N=1
+*
+ CALL DLARFG( N, A, A( 1, MIN( 2, N ) ), LDA, T )
+*
+ ELSE
+*
+* Otherwise, split A into blocks...
+*
+ M1 = M/2
+ M2 = M-M1
+ I1 = MIN( M1+1, M )
+ J1 = MIN( M+1, N )
+*
+* Compute A(1:M1,1:N) <- (Y1,R1,T1), where Q1 = I - Y1 T1 Y1^H
+*
+ CALL DGELQT3( M1, N, A, LDA, T, LDT, IINFO )
+*
+* Compute A(J1:M,1:N) = Q1^H A(J1:M,1:N) [workspace: T(1:N1,J1:N)]
+*
+ DO I=1,M2
+ DO J=1,M1
+ T( I+M1, J ) = A( I+M1, J )
+ END DO
+ END DO
+ CALL DTRMM( 'R', 'U', 'T', 'U', M2, M1, ONE,
+ & A, LDA, T( I1, 1 ), LDT )
+*
+ CALL DGEMM( 'N', 'T', M2, M1, N-M1, ONE, A( I1, I1 ), LDA,
+ & A( 1, I1 ), LDA, ONE, T( I1, 1 ), LDT)
+*
+ CALL DTRMM( 'R', 'U', 'N', 'N', M2, M1, ONE,
+ & T, LDT, T( I1, 1 ), LDT )
+*
+ CALL DGEMM( 'N', 'N', M2, N-M1, M1, -ONE, T( I1, 1 ), LDT,
+ & A( 1, I1 ), LDA, ONE, A( I1, I1 ), LDA )
+*
+ CALL DTRMM( 'R', 'U', 'N', 'U', M2, M1 , ONE,
+ & A, LDA, T( I1, 1 ), LDT )
+*
+ DO I=1,M2
+ DO J=1,M1
+ A( I+M1, J ) = A( I+M1, J ) - T( I+M1, J )
+ T( I+M1, J )=0
+ END DO
+ END DO
+*
+* Compute A(J1:M,J1:N) <- (Y2,R2,T2) where Q2 = I - Y2 T2 Y2^H
+*
+ CALL DGELQT3( M2, N-M1, A( I1, I1 ), LDA,
+ & T( I1, I1 ), LDT, IINFO )
+*
+* Compute T3 = T(J1:N1,1:N) = -T1 Y1^H Y2 T2
+*
+ DO I=1,M2
+ DO J=1,M1
+ T( J, I+M1 ) = (A( J, I+M1 ))
+ END DO
+ END DO
+*
+ CALL DTRMM( 'R', 'U', 'T', 'U', M1, M2, ONE,
+ & A( I1, I1 ), LDA, T( 1, I1 ), LDT )
+*
+ CALL DGEMM( 'N', 'T', M1, M2, N-M, ONE, A( 1, J1 ), LDA,
+ & A( I1, J1 ), LDA, ONE, T( 1, I1 ), LDT )
+*
+ CALL DTRMM( 'L', 'U', 'N', 'N', M1, M2, -ONE, T, LDT,
+ & T( 1, I1 ), LDT )
+*
+ CALL DTRMM( '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]
+*
+ END IF
+*
+ RETURN
+*
+* End of DGELQT3
+*
+ END
--- /dev/null
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE DGEMLQ( SIDE, TRANS, M, N, K, A, LDA, WORK1,
+* $ LWORK1, C, LDC, WORK2, LWORK2, INFO )
+*
+*
+* .. Scalar Arguments ..
+* CHARACTER SIDE, TRANS
+* INTEGER INFO, LDA, M, N, K, MB, NB, LWORK1, LWORK2, LDC
+* ..
+* .. Array Arguments ..
+* DOUBLE A( LDA, * ), WORK1( * ), C(LDC, * ),
+* $ WORK2( * )
+*> \par Purpose:
+* =============
+*>
+*> \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
+*> factorization (DGELQ)
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] SIDE
+*> SIDE is CHARACTER*1
+*> = 'L': apply Q or Q**T from the Left;
+*> = 'R': apply Q or Q**T from the Right.
+*>
+*> \param[in] TRANS
+*> TRANS is CHARACTER*1
+*> = 'N': No transpose, apply Q;
+*> = 'T': Transpose, apply Q**T.
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows of the matrix A. M >=0.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of columns of the matrix C. N >= M.
+*> \endverbatim
+*>
+*> \param[in] K
+*> \verbatim
+*> K is INTEGER
+*> The number of elementary reflectors whose product defines
+*> the matrix Q.
+*> M >= K >= 0;
+*>
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is DOUBLE PRECISION array, dimension (LDA,K)
+*> The i-th row must contain the vector which defines the blocked
+*> elementary reflector H(i), for i = 1,2,...,k, as returned by
+*> DLASWLQ in the first k rows of its array argument A.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A.
+*> If SIDE = 'L', LDA >= max(1,M);
+*> if SIDE = 'R', LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in] WORK1
+*> \verbatim
+*> WORK1 is DOUBLE PRECISION array, dimension (MAX(1,LWORK1)) is
+*> returned by GEQR.
+*> \endverbatim
+*>
+*> \param[in] LWORK1
+*> \verbatim
+*> LWORK1 is INTEGER
+*> The dimension of the array WORK1.
+*> \endverbatim
+*>
+*> \param[in,out] C
+*> C is DOUBLE PRECISION array, dimension (LDC,N)
+*> On entry, the M-by-N matrix C.
+*> On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.
+*> \param[in] LDC
+*> LDC is INTEGER
+*> The leading dimension of the array C. LDC >= max(1,M).
+*>
+*> \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 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)),
+*> and no error message related to LWORK2 is issued by XERBLA.
+*>
+*> \endverbatim
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> < 0: if INFO = -i, the i-th argument had an illegal value
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*> 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 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
+*> 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
+*> Further Details in LASWLQ or GELQT.
+*> \endverbatim
+*>
+* =====================================================================
+ SUBROUTINE DGEMLQ( SIDE, TRANS, M, N, K, A, LDA, WORK1, LWORK1,
+ $ C, LDC, WORK2, LWORK2, INFO )
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2013
+*
+* .. Scalar Arguments ..
+ CHARACTER SIDE, TRANS
+ INTEGER INFO, LDA, M, N, K, LWORK1, LWORK2, LDC
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), C( LDC, * ), WORK1( * ), WORK2( * )
+* ..
+*
+* =====================================================================
+*
+* ..
+* .. Local Scalars ..
+ LOGICAL LEFT, RIGHT, TRAN, NOTRAN, LQUERY
+ INTEGER I, II, KK, MB, NB, LW, NBLCKS, MN
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* .. External Subroutines ..
+ EXTERNAL DTPMLQT, DGEMLQT, XERBLA
+* .. Intrinsic Functions ..
+ INTRINSIC INT, MAX, MIN, MOD
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ LQUERY = (LWORK2.LT.0)
+ NOTRAN = LSAME( TRANS, 'N' )
+ TRAN = LSAME( TRANS, 'T' )
+ LEFT = LSAME( SIDE, 'L' )
+ RIGHT = LSAME( SIDE, 'R' )
+*
+ MB = INT(WORK1(4))
+ NB = INT(WORK1(5))
+ IF (LEFT) THEN
+ LW = N * MB
+ MN = M
+ ELSE
+ LW = M * MB
+ MN = N
+ END IF
+ IF ((NB.GT.K).AND.(MN.GT.K)) THEN
+ IF(MOD(MN-K, NB-K).EQ.0) THEN
+ NBLCKS = (MN-K)/(NB-K)
+ ELSE
+ NBLCKS = (MN-K)/(NB-K) + 1
+ END IF
+ ELSE
+ NBLCKS = 1
+ END IF
+*
+ INFO = 0
+ IF( .NOT.LEFT .AND. .NOT.RIGHT ) THEN
+ INFO = -1
+ ELSE IF( .NOT.TRAN .AND. .NOT.NOTRAN ) THEN
+ INFO = -2
+ ELSE IF( M.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( N.LT.0) THEN
+ INFO = -4
+ ELSE IF( K.LT.0 ) THEN
+ INFO = -5
+ ELSE IF( LDA.LT.MAX( 1, K ) ) THEN
+ INFO = -7
+ ELSE IF( LWORK1.LT.MAX( 1, MB*K*NBLCKS+5 )) THEN
+ INFO = -9
+ ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
+ INFO = -11
+ ELSE IF(( LWORK2.LT.MAX(1,LW)).AND.(.NOT.LQUERY)) THEN
+ INFO = -13
+ END IF
+*
+ IF( INFO.EQ.0) THEN
+ WORK2(1) = LW
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DGEMLQ', -INFO )
+ RETURN
+ ELSE IF (LQUERY) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( MIN(M,N,K).EQ.0 ) THEN
+ RETURN
+ 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)
+ ELSE
+ CALL DLAMSWLQ( SIDE, TRANS, M, N, K, MB, NB, A, LDA, WORK1(6),
+ $ MB, C, LDC, WORK2, LWORK2, INFO )
+ END IF
+*
+ WORK2(1) = LW
+*
+ RETURN
+*
+* End of DGEMLQ
+*
+ END
\ No newline at end of file
--- /dev/null
+*> \brief \b DGEMLQT
+*
+* =========== DOCUMENTATION ===========
+*
+* 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">
+*> [TXT]</a>
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* 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:
+* =============
+*>
+*> \verbatim
+*>
+*> DGEMQRT 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 K
+*> elementary reflectors:
+*>
+*> Q = H(1) H(2) . . . H(K) = I - V T V**T
+*>
+*> 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
+*
+* Arguments:
+* ==========
+*
+*> \param[in] SIDE
+*> \verbatim
+*> SIDE is CHARACTER*1
+*> = 'L': apply Q or Q**T from the Left;
+*> = 'R': apply Q or Q**T from the Right.
+*> \endverbatim
+*>
+*> \param[in] TRANS
+*> \verbatim
+*> TRANS is CHARACTER*1
+*> = 'N': No transpose, apply Q;
+*> = 'C': Transpose, apply Q**T.
+*> \endverbatim
+*>
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows of the matrix C. M >= 0.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of columns of the matrix C. N >= 0.
+*> \endverbatim
+*>
+*> \param[in] K
+*> \verbatim
+*> K is INTEGER
+*> The number of elementary reflectors whose product defines
+*> the matrix Q.
+*> If SIDE = 'L', M >= K >= 0;
+*> if SIDE = 'R', N >= K >= 0.
+*> \endverbatim
+*>
+*> \param[in] MB
+*> \verbatim
+*> MB is INTEGER
+*> The block size used for the storage of T. K >= MB >= 1.
+*> This must be the same value of MB used to generate T
+*> in DGELQT.
+*> \endverbatim
+*>
+*> \param[in] V
+*> \verbatim
+*> V is DOUBLE PRECISION array, dimension (LDV,K)
+*> The i-th row must contain the vector which defines the
+*> elementary reflector H(i), for i = 1,2,...,k, as returned by
+*> DGELQT in the first K rows of its array argument A.
+*> \endverbatim
+*>
+*> \param[in] LDV
+*> \verbatim
+*> LDV is INTEGER
+*> The leading dimension of the array V.
+*> If SIDE = 'L', LDA >= max(1,M);
+*> if SIDE = 'R', LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in] T
+*> \verbatim
+*> T is DOUBLE PRECISION array, dimension (LDT,K)
+*> The upper triangular factors of the block reflectors
+*> as returned by DGELQT, stored as a MB-by-M matrix.
+*> \endverbatim
+*>
+*> \param[in] LDT
+*> \verbatim
+*> LDT is INTEGER
+*> The leading dimension of the array T. LDT >= MB.
+*> \endverbatim
+*>
+*> \param[in,out] C
+*> \verbatim
+*> C is DOUBLE PRECISION array, dimension (LDC,N)
+*> On entry, the M-by-N matrix C.
+*> On exit, C is overwritten by Q C, Q**T C, C Q**T or C Q.
+*> \endverbatim
+*>
+*> \param[in] LDC
+*> \verbatim
+*> LDC is INTEGER
+*> The leading dimension of the array C. LDC >= max(1,M).
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is DOUBLE PRECISION array. The dimension of
+*> WORK is N*MB if SIDE = 'L', or M*MB if SIDE = 'R'.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> < 0: if INFO = -i, the i-th argument had an illegal value
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2013
+*
+*> \ingroup doubleGEcomputational
+*
+* =====================================================================
+ SUBROUTINE DGEMLQT( SIDE, TRANS, M, N, K, MB, V, LDV, T, LDT,
+ $ C, LDC, WORK, INFO )
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2013
+*
+* .. 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( * )
+* ..
+*
+* =====================================================================
+*
+* ..
+* .. Local Scalars ..
+ LOGICAL LEFT, RIGHT, TRAN, NOTRAN
+ INTEGER I, IB, LDWORK, KF, Q
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL XERBLA, DLARFB
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* .. Test the input arguments ..
+*
+ INFO = 0
+ LEFT = LSAME( SIDE, 'L' )
+ RIGHT = LSAME( SIDE, 'R' )
+ TRAN = LSAME( TRANS, 'T' )
+ NOTRAN = LSAME( TRANS, 'N' )
+*
+ IF( LEFT ) THEN
+ LDWORK = MAX( 1, N )
+ ELSE IF ( RIGHT ) THEN
+ LDWORK = MAX( 1, M )
+ END IF
+ IF( .NOT.LEFT .AND. .NOT.RIGHT ) THEN
+ INFO = -1
+ ELSE IF( .NOT.TRAN .AND. .NOT.NOTRAN ) THEN
+ INFO = -2
+ ELSE IF( M.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( K.LT.0) THEN
+ INFO = -5
+ ELSE IF( MB.LT.1 .OR. (MB.GT.K .AND. K.GT.0)) THEN
+ INFO = -6
+ ELSE IF( LDV.LT.MAX( 1, K ) ) THEN
+ INFO = -8
+ ELSE IF( LDT.LT.MB ) THEN
+ INFO = -10
+ ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
+ INFO = -12
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DGEMLQT', -INFO )
+ RETURN
+ END IF
+*
+* .. Quick return if possible ..
+*
+ IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) RETURN
+*
+ IF( LEFT .AND. NOTRAN ) 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,
+ $ 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,
+ $ C( 1, I ), LDC, WORK, LDWORK )
+ END DO
+*
+ ELSE IF( LEFT .AND. TRAN ) THEN
+*
+ 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,
+ $ C( I, 1 ), LDC, WORK, LDWORK )
+ END DO
+*
+ ELSE IF( RIGHT .AND. NOTRAN ) THEN
+*
+ 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,
+ $ C( 1, I ), LDC, WORK, LDWORK )
+ END DO
+*
+ END IF
+*
+ RETURN
+*
+* End of DGEMLQT
+*
+ END
--- /dev/null
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE DGEMQR( SIDE, TRANS, M, N, K, A, LDA, WORK1,
+* $ LWORK1, C, LDC, WORK2, LWORK2, INFO )
+*
+*
+* .. Scalar Arguments ..
+* CHARACTER SIDE, TRANS
+* INTEGER INFO, LDA, M, N, K, LDT, LWORK1, LWORK2, LDC
+* ..
+* .. Array Arguments ..
+* 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
+*> QR factorization (DGEQR)
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] SIDE
+*> SIDE is CHARACTER*1
+*> = 'L': apply Q or Q**T from the Left;
+*> = 'R': apply Q or Q**T from the Right.
+*>
+*> \param[in] TRANS
+*> TRANS is CHARACTER*1
+*> = 'N': No transpose, apply Q;
+*> = 'T': Transpose, apply Q**T.
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows of the matrix A. M >=0.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of columns of the matrix C. M >= N >= 0.
+*> \endverbatim
+*>
+*> \param[in] K
+*> \verbatim
+*> K is INTEGER
+*> The number of elementary reflectors whose product defines
+*> the matrix Q.
+*> N >= K >= 0;
+*>
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is DOUBLE PRECISION array, dimension (LDA,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
+*> its array argument A.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A.
+*> If SIDE = 'L', LDA >= max(1,M);
+*> if SIDE = 'R', LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in] WORK1
+*> \verbatim
+*> WORK1 is DOUBLE PRECISION array, dimension (MAX(1,LWORK1)) as
+*> it is returned by GEQR.
+*> \endverbatim
+*>
+*> \param[in] LWORK1
+*> \verbatim
+*> LWORK1 is INTEGER
+*> The dimension of the array WORK1.
+*> \endverbatim
+*>
+*> \param[in,out] C
+*> C is DOUBLE PRECISION array, dimension (LDC,N)
+*> On entry, the M-by-N matrix C.
+*> On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.
+*>
+*> \param[in] LDC
+*> LDC is INTEGER
+*> The leading dimension of the array C. LDC >= max(1,M).
+*>
+*> \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 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)),
+*> and no error message related to LWORK2 is issued by XERBLA.
+*>
+*> \endverbatim
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> < 0: if INFO = -i, the i-th argument had an illegal value
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*> 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 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
+*> Further Details in LATSQR or GEQRT.
+*> \endverbatim
+*>
+* =====================================================================
+ SUBROUTINE DGEMQR( SIDE, TRANS, M, N, K, A, LDA, WORK1, LWORK1,
+ $ C, LDC, WORK2, LWORK2, INFO )
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2013
+*
+* .. Scalar Arguments ..
+ CHARACTER SIDE, TRANS
+ INTEGER INFO, LDA, M, N, K, LWORK1, LWORK2, LDC
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), WORK1( * ), C(LDC, * ),
+ $ WORK2( * )
+* ..
+*
+* =====================================================================
+*
+* ..
+* .. Local Scalars ..
+ LOGICAL LEFT, RIGHT, TRAN, NOTRAN, LQUERY
+ INTEGER MB, NB, I, II, KK, LW, NBLCKS, MN
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* .. External Subroutines ..
+ EXTERNAL DGEMQRT, DTPMQRT, XERBLA
+* .. Intrinsic Functions ..
+ INTRINSIC INT, MAX, MIN, MOD
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ LQUERY = LWORK2.LT.0
+ NOTRAN = LSAME( TRANS, 'N' )
+ TRAN = LSAME( TRANS, 'T' )
+ LEFT = LSAME( SIDE, 'L' )
+ RIGHT = LSAME( SIDE, 'R' )
+*
+ MB = INT(WORK1(4))
+ NB = INT(WORK1(5))
+ IF(LEFT) THEN
+ LW = N * NB
+ MN = M
+ ELSE IF(RIGHT) THEN
+ LW = MB * NB
+ MN = N
+ END IF
+*
+ IF ((MB.GT.K).AND.(MN.GT.K)) THEN
+ IF(MOD(MN-K, MB-K).EQ.0) THEN
+ NBLCKS = (MN-K)/(MB-K)
+ ELSE
+ NBLCKS = (MN-K)/(MB-K) + 1
+ END IF
+ ELSE
+ NBLCKS = 1
+ END IF
+*
+ INFO = 0
+ IF( .NOT.LEFT .AND. .NOT.RIGHT ) THEN
+ INFO = -1
+ ELSE IF( .NOT.TRAN .AND. .NOT.NOTRAN ) THEN
+ INFO = -2
+ ELSE IF( M.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( K.LT.0 ) THEN
+ INFO = -5
+ ELSE IF( LDA.LT.MAX( 1, K ) ) THEN
+ INFO = -7
+ ELSE IF( LWORK1.LT.MAX( 1, NB*K*NBLCKS+5 )) THEN
+ INFO = -9
+ ELSE IF( LDC.LT.MAX( 1, M ).AND.MIN(M,N,K).NE.0 ) THEN
+ INFO = -11
+ ELSE IF(( LWORK2.LT.MAX(1,LW)).AND.(.NOT.LQUERY)) THEN
+ INFO = -13
+ 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( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DGEMQR', -INFO )
+ RETURN
+ ELSE IF (LQUERY) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( MIN(M,N,K).EQ.0 ) THEN
+ RETURN
+ 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 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
+*
+ WORK2(1) = LW
+*
+ RETURN
+*
+* End of DGEMQR
+*
+ END
\ No newline at end of file
--- /dev/null
+*
+* 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:
+*> A = Q * R .
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows of the matrix A. M >= 0.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of columns of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is 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
+*> (R is upper triangular if M >= N);
+*> the elements below the diagonal represent Q (see Further Details).
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,M).
+*> \endverbatim
+*>
+*> \param[out] WORK1
+*> \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
+*> 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
+*> DLATSQR or DGEQRT
+*> \endverbatim
+*>
+*> \param[in] LWORK1
+*> \verbatim
+*> LWORK1 is INTEGER
+*> The dimension of the array WORK1.
+*> 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
+*> 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
+*> 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
+*> LWORK2 = -1.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> < 0: if INFO = -i, the i-th argument had an illegal value
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*> 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 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
+*> Further Details in LATSQR or GEQRT.
+*> \endverbatim
+*>
+* =====================================================================
+ SUBROUTINE DGEQR( M, N, A, LDA, WORK1, LWORK1, WORK2, LWORK2,
+ $ INFO)
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd. --
+* November 2013
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, M, N, LWORK1, LWORK2
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), WORK1( * ), WORK2( * )
+* ..
+*
+* =====================================================================
+*
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY, LMINWS
+ INTEGER MB, NB, I, II, KK, MINLW1, NBLCKS
+* ..
+* .. EXTERNAL FUNCTIONS ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* .. EXTERNAL SUBROUTINES ..
+ EXTERNAL DLATSQR, DGEQRT, XERBLA
+* .. INTRINSIC FUNCTIONS ..
+ INTRINSIC MAX, MIN, MOD
+* ..
+* .. EXTERNAL FUNCTIONS ..
+ INTEGER ILAENV
+ EXTERNAL ILAENV
+* ..
+* .. EXECUTABLE STATEMENTS ..
+*
+* TEST THE INPUT ARGUMENTS
+*
+ INFO = 0
+*
+ LQUERY = ( LWORK1.EQ.-1 .OR. LWORK2.EQ.-1 )
+*
+* 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)
+ ELSE
+ MB = M
+ NB = 1
+ END IF
+ IF( MB.GT.M.OR.MB.LE.N) MB = M
+ IF( NB.GT.MIN(M,N).OR.NB.LT.1) NB = 1
+ MINLW1 = N + 5
+ IF ((MB.GT.N).AND.(M.GT.N)) THEN
+ IF(MOD(M-N, MB-N).EQ.0) THEN
+ NBLCKS = (M-N)/(MB-N)
+ ELSE
+ NBLCKS = (M-N)/(MB-N) + 1
+ END IF
+ ELSE
+ NBLCKS = 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)
+ $ .AND.(.NOT.LQUERY)) THEN
+ IF (LWORK1.LT.MAX(1, NB * N * NBLCKS+5)) THEN
+ LMINWS = .TRUE.
+ NB = 1
+ END IF
+ IF (LWORK1.LT.MAX(1, N * NBLCKS+5)) THEN
+ LMINWS = .TRUE.
+ MB = M
+ END IF
+ IF (LWORK2.LT.NB*N) THEN
+ LMINWS = .TRUE.
+ NB = 1
+ END IF
+ END IF
+*
+ IF( M.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -4
+ 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)
+ $ .AND.(.NOT.LMINWS)) THEN
+ INFO = -8
+ END IF
+
+ IF( INFO.EQ.0) THEN
+ WORK1(1) = 1
+ WORK1(2) = NB * N * NBLCKS + 5
+ WORK1(3) = MINLW1
+ WORK1(4) = MB
+ WORK1(5) = NB
+ WORK2(1) = NB * N
+ WORK2(2) = N
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DGEQR', -INFO )
+ RETURN
+ ELSE IF (LQUERY) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( MIN(M,N).EQ.0 ) THEN
+ RETURN
+ END IF
+*
+* The QR Decomposition
+*
+ 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,
+ $ LWORK2, INFO)
+ END IF
+ RETURN
+*
+* End of DGEQR
+*
+ END
\ No newline at end of file
--- /dev/null
+* Definition:
+* ===========
+*
+* SUBROUTINE DGETSLS( 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 ..
+* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), WORK( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> DGETSLS solves overdetermined or underdetermined real linear systems
+*> 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:
+*>
+*> 1. If TRANS = 'N' and m >= n: find the least squares solution of
+*> an overdetermined system, i.e., solve the least squares problem
+*> minimize || B - A*X ||.
+
+*> 2. If TRANS = 'N' and m < n: find the minimum norm solution of
+*> an underdetermined system A * X = B.
+
+*> 3. If TRANS = 'T' and m >= n: find the minimum norm solution of
+*> an undetermined system A**T * X = B.
+
+*> 4. If TRANS = 'T' and m < n: find the least squares solution of
+*> an overdetermined system, i.e., solve the least squares problem
+*> minimize || B - A**T * X ||.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] TRANS
+*> \verbatim
+*> TRANS is CHARACTER*1
+*> = 'N': the linear system involves A;
+*> = 'T': the linear system involves A**T.
+*> \endverbatim
+*>
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows of the matrix A. M >= 0.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of columns of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in] NRHS
+*> \verbatim
+*> NRHS is INTEGER
+*> The number of right hand sides, i.e., the number of
+*> columns of the matrices B and X. NRHS >=0.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is DOUBLE PRECISION array, dimension (LDA,N)
+*> On entry, the M-by-N matrix A.
+*> On exit,
+*> A is overwritten by details of its QR or LQ
+*> factorization as returned by DGETSQR.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,M).
+*> \endverbatim
+*>
+*> \param[in,out] B
+*> \verbatim
+*> B is DOUBLE PRECISION array, dimension (LDB,NRHS)
+*> On entry, the matrix B of right hand side vectors, stored
+*> columnwise; B is M-by-NRHS if TRANS = 'N', or N-by-NRHS
+*> if TRANS = 'T'.
+*> On exit, if INFO = 0, B is overwritten by the solution
+*> vectors, stored columnwise:
+*> if TRANS = 'N' and m >= n, rows 1 to n of B contain the least
+*> squares solution vectors.
+*> if TRANS = 'N' and m < n, rows 1 to N of B contain the
+*> minimum norm solution vectors;
+*> if TRANS = 'T' and m >= n, rows 1 to M of B contain the
+*> minimum norm solution vectors;
+*> if TRANS = 'T' and m < n, rows 1 to M of B contain the
+*> least squares solution vectors.
+*> \endverbatim
+*>
+*> \param[in] LDB
+*> \verbatim
+*> LDB is INTEGER
+*> The leading dimension of the array B. LDB >= MAX(1,M,N).
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK,
+*> and WORK(2) returns the minimum LWORK.
+*> \endverbatim
+*>
+*> \param[in] LWORK
+*> \verbatim
+*> LWORK is INTEGER
+*> The dimension of the array WORK.
+*> IF LWORK=-1, workspace query is assumed, and
+*> WORK(1) returns the optimal LWORK,
+*> and WORK(2) returns the minimum LWORK.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> < 0: if INFO = -i, the i-th argument had an illegal value
+*> > 0: if INFO = i, the i-th diagonal element of the
+*> triangular factor of A is zero, so that A does not have
+*> full rank; the least squares solution could not be
+*> computed.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2011
+*
+*> \ingroup doubleGEsolve
+*
+* =====================================================================
+ SUBROUTINE DGETSLS( TRANS, M, N, NRHS, A, LDA, B, LDB
+ $ , WORK, LWORK, INFO )
+*
+* -- LAPACK driver routine (version 3.4.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2011
+*
+* .. Scalar Arguments ..
+ CHARACTER TRANS
+ INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS, MB
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), B( LDB, * ), WORK( * )
+*
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY, TRAN
+ INTEGER I, IASCL, IBSCL, J, MINMN, MAXMN, BROW, LW,
+ $ SCLLEN, MNK, WSIZEO, WSIZEM, LW1, LW2, INFO2
+ DOUBLE PRECISION ANRM, BIGNUM, BNRM, SMLNUM
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ DOUBLE PRECISION DLAMCH, DLANGE
+ EXTERNAL LSAME, ILAENV, DLABAD, DLAMCH, DLANGE
+* ..
+* .. External Subroutines ..
+ EXTERNAL DGEQR, DGEMQR, DLASCL, DLASET,
+ $ DTRTRS, XERBLA, DGELQ, DGEMLQ
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC DBLE, MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments.
+*
+ INFO=0
+ MINMN = MIN( M, N )
+ MAXMN = MAX( M, N )
+ MNK = MAX(MINMN,NRHS)
+ TRAN = LSAME( TRANS, 'T' )
+*
+ LQUERY = ( LWORK.EQ.-1 )
+ IF( .NOT.( LSAME( TRANS, 'N' ) .OR.
+ $ LSAME( TRANS, 'T' ) ) ) THEN
+ INFO = -1
+ ELSE IF( M.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -6
+ ELSE IF( LDB.LT.MAX( 1, M, N ) ) THEN
+ INFO = -8
+ END IF
+*
+ IF( INFO.EQ.0) THEN
+*
+* Determine the block size and minimum LWORK
+*
+ IF ( M.GE.N ) THEN
+ CALL DGEQR( M, N, A, LDA, WORK(1), -1, WORK(6), -1,
+ $ INFO2)
+ MB = INT(WORK(4))
+ NB = INT(WORK(5))
+ LW = INT(WORK(6))
+ CALL DGEMQR( 'L', TRANS, M, NRHS, N, A, LDA, WORK(1),
+ $ 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 DGELQ( M, N, A, LDA, WORK(1), -1, WORK(6), -1,
+ $ INFO2)
+ MB = INT(WORK(4))
+ NB = INT(WORK(5))
+ LW = INT(WORK(6))
+ CALL DGEMLQ( 'L', TRANS, N, NRHS, M, A, LDA, WORK(1),
+ $ 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)))
+ END IF
+*
+ IF((LWORK.LT.WSIZEO).AND.(.NOT.LQUERY)) THEN
+ INFO=-10
+ END IF
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DGETSLS', -INFO )
+ WORK( 1 ) = DBLE( WSIZEO )
+ WORK( 2 ) = DBLE( WSIZEM )
+ RETURN
+ ELSE IF (LQUERY) THEN
+ WORK( 1 ) = DBLE( WSIZEO )
+ WORK( 2 ) = DBLE( WSIZEM )
+ RETURN
+ END IF
+ IF(LWORK.LT.WSIZEO) THEN
+ LW1=INT(WORK(3))
+ LW2=MAX(LW,INT(WORK(6)))
+ ELSE
+ LW1=INT(WORK(2))
+ LW2=MAX(LW,INT(WORK(6)))
+ END IF
+*
+* Quick return if possible
+*
+ IF( MIN( M, N, NRHS ).EQ.0 ) THEN
+ CALL DLASET( 'FULL', MAX( M, N ), NRHS, ZERO, ZERO,
+ $ B, LDB )
+ RETURN
+ END IF
+*
+* Get machine parameters
+*
+ SMLNUM = DLAMCH( 'S' ) / DLAMCH( 'P' )
+ BIGNUM = ONE / SMLNUM
+ CALL DLABAD( SMLNUM, BIGNUM )
+*
+* Scale A, B if max element outside range [SMLNUM,BIGNUM]
+*
+ ANRM = DLANGE( 'M', M, N, A, LDA, RWORK )
+ IASCL = 0
+ IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
+*
+* Scale matrix norm up to SMLNUM
+*
+ CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, INFO )
+ IASCL = 1
+ ELSE IF( ANRM.GT.BIGNUM ) THEN
+*
+* Scale matrix norm down to BIGNUM
+*
+ CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, INFO )
+ IASCL = 2
+ ELSE IF( ANRM.EQ.ZERO ) THEN
+*
+* Matrix all zero. Return zero solution.
+*
+ CALL DLASET( 'F', MAXMN, NRHS, ZERO, ZERO, B, LDB )
+ GO TO 50
+ END IF
+*
+ BROW = M
+ IF ( TRAN ) THEN
+ BROW = N
+ END IF
+ BNRM = DLANGE( 'M', BROW, NRHS, B, LDB, RWORK )
+ IBSCL = 0
+ IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
+*
+* Scale matrix norm up to SMLNUM
+*
+ CALL DLASCL( 'G', 0, 0, BNRM, SMLNUM, BROW, NRHS, B, LDB,
+ $ INFO )
+ IBSCL = 1
+ ELSE IF( BNRM.GT.BIGNUM ) THEN
+*
+* Scale matrix norm down to BIGNUM
+*
+ CALL DLASCL( 'G', 0, 0, BNRM, BIGNUM, BROW, NRHS, B, LDB,
+ $ INFO )
+ IBSCL = 2
+ END IF
+*
+ IF ( M.GE.N) THEN
+*
+* compute QR factorization of A
+*
+ CALL DGEQR( M, N, A, LDA, WORK(LW2+1), LW1
+ $ , WORK(1), LW2, INFO )
+ IF (.NOT.TRAN) THEN
+*
+* Least-Squares Problem min || A * X - B ||
+*
+* B(1:M,1:NRHS) := Q**T * B(1:M,1:NRHS)
+*
+ CALL DGEMQR( '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 DTRTRS( 'U', 'N', 'N', N, NRHS,
+ $ A, LDA, B, LDB, INFO )
+ IF(INFO.GT.0) THEN
+ RETURN
+ END IF
+ SCLLEN = N
+ ELSE
+*
+* Overdetermined system of equations A**T * X = B
+*
+* B(1:N,1:NRHS) := inv(R**T) * B(1:N,1:NRHS)
+*
+ CALL DTRTRS( 'U', 'T', 'N', N, NRHS,
+ $ A, LDA, B, LDB, INFO )
+*
+ IF( INFO.GT.0 ) THEN
+ RETURN
+ END IF
+*
+* B(N+1:M,1:NRHS) = ZERO
+*
+ DO 20 J = 1, NRHS
+ DO 10 I = N + 1, M
+ B( I, J ) = ZERO
+ 10 CONTINUE
+ 20 CONTINUE
+*
+* B(1:M,1:NRHS) := Q(1:N,:) * B(1:N,1:NRHS)
+*
+ CALL DGEMQR( 'L', 'N', M, NRHS, N, A, LDA,
+ $ WORK( LW2+1), LW1, B, LDB, WORK( 1 ), LW2,
+ $ INFO )
+*
+ SCLLEN = M
+*
+ END IF
+*
+ ELSE
+*
+* Compute LQ factorization of A
+*
+ CALL DGELQ( M, N, A, LDA, WORK(LW2+1), LW1
+ $ , WORK(1), LW2, INFO )
+*
+* workspace at least M, optimally M*NB.
+*
+ IF( .NOT.TRAN ) THEN
+*
+* underdetermined system of equations A * X = B
+*
+* B(1:M,1:NRHS) := inv(L) * B(1:M,1:NRHS)
+*
+ CALL DTRTRS( 'L', 'N', 'N', M, NRHS,
+ $ A, LDA, B, LDB, INFO )
+*
+ IF( INFO.GT.0 ) THEN
+ RETURN
+ END IF
+*
+* B(M+1:N,1:NRHS) = 0
+*
+ DO 40 J = 1, NRHS
+ DO 30 I = M + 1, N
+ B( I, J ) = ZERO
+ 30 CONTINUE
+ 40 CONTINUE
+*
+* B(1:N,1:NRHS) := Q(1:N,:)**T * B(1:M,1:NRHS)
+*
+ CALL DGEMLQ( 'L', 'T', N, NRHS, M, A, LDA,
+ $ WORK( LW2+1), LW1, B, LDB, WORK( 1 ), LW2,
+ $ INFO )
+*
+* workspace at least NRHS, optimally NRHS*NB
+*
+ SCLLEN = N
+*
+ ELSE
+*
+* overdetermined system min || A**T * X - B ||
+*
+* B(1:N,1:NRHS) := Q * B(1:N,1:NRHS)
+*
+ CALL DGEMLQ( 'L', 'N', N, NRHS, M, A, LDA,
+ $ WORK( LW2+1), LW1, B, LDB, WORK( 1 ), LW2,
+ $ INFO )
+*
+* workspace at least NRHS, optimally NRHS*NB
+*
+* B(1:M,1:NRHS) := inv(L**T) * B(1:M,1:NRHS)
+*
+ CALL DTRTRS( 'Lower', 'Transpose', 'Non-unit', M, NRHS,
+ $ A, LDA, B, LDB, INFO )
+*
+ IF( INFO.GT.0 ) THEN
+ RETURN
+ END IF
+*
+ SCLLEN = M
+*
+ END IF
+*
+ END IF
+*
+* Undo scaling
+*
+ IF( IASCL.EQ.1 ) THEN
+ CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, SCLLEN, NRHS, B, LDB,
+ $ INFO )
+ ELSE IF( IASCL.EQ.2 ) THEN
+ CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, SCLLEN, NRHS, B, LDB,
+ $ INFO )
+ END IF
+ IF( IBSCL.EQ.1 ) THEN
+ CALL DLASCL( 'G', 0, 0, SMLNUM, BNRM, SCLLEN, NRHS, B, LDB,
+ $ INFO )
+ ELSE IF( IBSCL.EQ.2 ) THEN
+ CALL DLASCL( 'G', 0, 0, BIGNUM, BNRM, SCLLEN, NRHS, B, LDB,
+ $ INFO )
+ END IF
+*
+ 50 CONTINUE
+ WORK( 1 ) = DBLE( WSIZEO )
+ WORK( 2 ) = DBLE( WSIZEM )
+ RETURN
+*
+* End of DGETSLS
+*
+ END
\ No newline at end of file
--- /dev/null
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE DLAMSWLQ( SIDE, TRANS, M, N, K, MB, NB, A, LDA, T,
+* $ LDT, C, LDC, WORK, LWORK, INFO )
+*
+*
+* .. Scalar Arguments ..
+* CHARACTER SIDE, TRANS
+* INTEGER INFO, LDA, M, N, K, MB, NB, LDT, LWORK, LDC
+* ..
+* .. Array Arguments ..
+* DOUBLE A( LDA, * ), WORK( * ), C(LDC, * ),
+* $ T( LDT, * )
+*> \par Purpose:
+* =============
+*>
+*> \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
+*> factorization (DLASWLQ)
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] SIDE
+*> SIDE is CHARACTER*1
+*> = 'L': apply Q or Q**T from the Left;
+*> = 'R': apply Q or Q**T from the Right.
+*>
+*> \param[in] TRANS
+*> TRANS is CHARACTER*1
+*> = 'N': No transpose, apply Q;
+*> = 'T': Transpose, apply Q**T.
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows of the matrix A. M >=0.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of columns of the matrix C. N >= M.
+*> \endverbatim
+*>
+*> \param[in] K
+*> \verbatim
+*> K is INTEGER
+*> The number of elementary reflectors whose product defines
+*> the matrix Q.
+*> M >= K >= 0;
+*>
+*> \endverbatim
+*> \param[in] MB
+*> \verbatim
+*> MB is INTEGER
+*> 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.
+*> NB > M.
+*> \endverbatim
+*>
+*> \param[in] NB
+*> \verbatim
+*> NB is INTEGER
+*> The block size to be used in the blocked QR.
+*> MB > M.
+*>
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is DOUBLE PRECISION array, dimension (LDA,K)
+*> The i-th row must contain the vector which defines the blocked
+*> elementary reflector H(i), for i = 1,2,...,k, as returned by
+*> DLASWLQ in the first k rows of its array argument A.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A.
+*> If SIDE = 'L', LDA >= max(1,M);
+*> if SIDE = 'R', LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in] T
+*> \verbatim
+*> 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
+*> for further details.
+*> \endverbatim
+*>
+*> \param[in] LDT
+*> \verbatim
+*> LDT is INTEGER
+*> The leading dimension of the array T. LDT >= MB.
+*> \endverbatim
+*>
+*> \param[in,out] C
+*> C is DOUBLE PRECISION array, dimension (LDC,N)
+*> On entry, the M-by-N matrix C.
+*> On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.
+*> \param[in] LDC
+*> LDC is INTEGER
+*> The leading dimension of the array C. LDC >= max(1,M).
+*>
+*> \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,NB) * MB;
+*> if SIDE = 'R', LWORK >= max(1,M) * MB.
+*> If LWORK = -1, then a workspace query is assumed; the routine
+*> only calculates the optimal size of the WORK array, returns
+*> this value as the first entry of the WORK array, and no error
+*> message related to LWORK is issued by XERBLA.
+*>
+*> \endverbatim
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> < 0: if INFO = -i, the i-th argument had an illegal value
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*> Short-Wide LQ (SWLQ) performs LQ by a sequence of orthogonal transformations,
+*> representing Q as a product of other orthogonal matrices
+*> Q = Q(1) * Q(2) * . . . * Q(k)
+*> where each Q(i) zeros out upper diagonal entries of a block of NB rows of A:
+*> Q(1) zeros out the upper diagonal entries of rows 1:NB of A
+*> Q(2) zeros out the bottom MB-N rows of rows [1:M,NB+1:2*NB-M] of A
+*> Q(3) zeros out the bottom MB-N rows of rows [1:M,2*NB-M+1:3*NB-2*M] of A
+*> . . .
+*>
+*> Q(1) is computed by GELQT, which represents Q(1) by Householder vectors
+*> stored under the diagonal of rows 1:MB of A, and by upper triangular
+*> block reflectors, stored in array T(1:LDT,1:N).
+*> For more information see Further Details in GELQT.
+*>
+*> Q(i) for i>1 is computed by TPLQT, which represents Q(i) by Householder vectors
+*> stored in columns [(i-1)*(NB-M)+M+1:i*(NB-M)+M] of A, and by upper triangular
+*> 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].
+*>
+*> [1] “Communication-Optimal Parallel and Sequential QR and LU Factorizations,”
+*> J. Demmel, L. Grigori, M. Hoemmen, J. Langou,
+*> SIAM J. Sci. Comput, vol. 34, no. 1, 2012
+*> \endverbatim
+*>
+* =====================================================================
+ 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) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2013
+*
+* .. Scalar Arguments ..
+ CHARACTER SIDE, TRANS
+ INTEGER INFO, LDA, M, N, K, MB, NB, LDT, LWORK, LDC
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), WORK( * ), C(LDC, * ),
+ $ T( LDT, * )
+* ..
+*
+* =====================================================================
+*
+* ..
+* .. Local Scalars ..
+ LOGICAL LEFT, RIGHT, TRAN, NOTRAN, LQUERY
+ INTEGER I, II, KK, CTR, LW
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* .. External Subroutines ..
+ EXTERNAL DTPMLQT, DGEMLQT, XERBLA
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ LQUERY = LWORK.LT.0
+ NOTRAN = LSAME( TRANS, 'N' )
+ TRAN = LSAME( TRANS, 'T' )
+ LEFT = LSAME( SIDE, 'L' )
+ RIGHT = LSAME( SIDE, 'R' )
+ IF (LEFT) THEN
+ LW = N * MB
+ ELSE
+ LW = M * MB
+ END IF
+*
+ INFO = 0
+ IF( .NOT.LEFT .AND. .NOT.RIGHT ) THEN
+ INFO = -1
+ ELSE IF( .NOT.TRAN .AND. .NOT.NOTRAN ) THEN
+ INFO = -2
+ ELSE IF( M.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( K.LT.0 ) THEN
+ INFO = -5
+ ELSE IF( LDA.LT.MAX( 1, K ) ) THEN
+ INFO = -9
+ ELSE IF( LDT.LT.MAX( 1, MB) ) THEN
+ INFO = -11
+ ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
+ INFO = -13
+ ELSE IF(( LWORK.LT.MAX(1,LW)).AND.(.NOT.LQUERY)) THEN
+ INFO = -15
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DLAMSWLQ', -INFO )
+ WORK(1) = LW
+ RETURN
+ ELSE IF (LQUERY) THEN
+ WORK(1) = LW
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( MIN(M,N,K).EQ.0 ) THEN
+ RETURN
+ 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)
+ RETURN
+ END IF
+*
+ IF(LEFT.AND.TRAN) THEN
+*
+* Multiply Q to the last block of C
+*
+ KK = MOD((M-K),(NB-K))
+ CTR = (M-K)/(NB-K)
+ IF (KK.GT.0) THEN
+ II=M-KK+1
+ CALL DTPMLQT('L','T',KK , N, K, 0, MB, A(1,II), LDA,
+ $ T(1,CTR*K+1), LDT, C(1,1), LDC,
+ $ C(II,1), LDC, WORK, INFO )
+ ELSE
+ II=M+1
+ END IF
+*
+ DO I=II-(NB-K),NB+1,-(NB-K)
+*
+* Multiply Q to the current block of C (1:M,I:I+NB)
+*
+ CTR = CTR - 1
+ CALL DTPMLQT('L','T',NB-K , N, K, 0,MB, A(1,I), 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:M,1:NB)
+*
+ CALL DGEMLQT('L','T',NB , N, K, MB, A(1,1), LDA, T
+ $ ,LDT ,C(1,1), LDC, WORK, INFO )
+*
+ ELSE IF (LEFT.AND.NOTRAN) THEN
+*
+* Multiply Q to the first block of C
+*
+ KK = MOD((M-K),(NB-K))
+ II=M-KK+1
+ CTR = 1
+ CALL DGEMLQT('L','N',NB , N, K, MB, A(1,1), LDA, T
+ $ ,LDT ,C(1,1), LDC, WORK, INFO )
+*
+ DO I=NB+1,II-NB+K,(NB-K)
+*
+* Multiply Q to the current block of C (I:I+NB,1:N)
+*
+ CALL DTPMLQT('L','N',NB-K , N, K, 0,MB, A(1,I), LDA,
+ $ T(1,CTR*K+1), LDT, C(1,1), LDC,
+ $ C(I,1), LDC, WORK, INFO )
+ CTR = CTR + 1
+*
+ END DO
+ IF(II.LE.M) THEN
+*
+* Multiply Q to the last block of C
+*
+ CALL DTPMLQT('L','N',KK , N, K, 0, MB, A(1,II), LDA,
+ $ T(1,CTR*K+1), LDT, C(1,1), LDC,
+ $ C(II,1), LDC, WORK, INFO )
+*
+ END IF
+*
+ ELSE IF(RIGHT.AND.NOTRAN) THEN
+*
+* Multiply Q to the last block of C
+*
+ KK = MOD((N-K),(NB-K))
+ CTR = (N-K)/(NB-K)
+ IF (KK.GT.0) THEN
+ II=N-KK+1
+ CALL DTPMLQT('R','N',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 )
+ ELSE
+ II=N+1
+ END IF
+*
+ DO I=II-(NB-K),NB+1,-(NB-K)
+*
+* Multiply Q to the current block of C (1:M,I:I+MB)
+*
+ 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 )
+*
+ END DO
+*
+* Multiply Q to the first block of C (1:M,1:MB)
+*
+ CALL DGEMLQT('R','N',M , NB, K, MB, A(1,1), LDA, T
+ $ ,LDT ,C(1,1), LDC, WORK, INFO )
+*
+ ELSE IF (RIGHT.AND.TRAN) THEN
+*
+* Multiply Q to the first block of C
+*
+ KK = MOD((N-K),(NB-K))
+ CTR = 1
+ II=N-KK+1
+ CALL DGEMLQT('R','T',M , NB, K, MB, A(1,1), LDA, T
+ $ ,LDT ,C(1,1), LDC, WORK, INFO )
+*
+ DO I=NB+1,II-NB+K,(NB-K)
+*
+* Multiply Q to the current block of C (1:M,I:I+MB)
+*
+ CALL DTPMLQT('R','T',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 )
+ CTR = CTR + 1
+*
+ END DO
+ 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 IF
+*
+ END IF
+*
+ WORK(1) = LW
+ RETURN
+*
+* End of DLAMSWLQ
+*
+ END
\ No newline at end of file
--- /dev/null
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE DLAMTSQR( SIDE, TRANS, M, N, K, MB, NB, A, LDA, T,
+* $ LDT, C, LDC, WORK, LWORK, INFO )
+*
+*
+* .. Scalar Arguments ..
+* CHARACTER SIDE, TRANS
+* INTEGER INFO, LDA, M, N, K, MB, NB, LDT, LWORK, LDC
+* ..
+* .. Array Arguments ..
+* DOUBLE A( LDA, * ), WORK( * ), C(LDC, * ),
+* $ T( LDT, * )
+*> \par Purpose:
+* =============
+*>
+*> \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
+*> QR factorization (DLATSQR)
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] SIDE
+*> SIDE is CHARACTER*1
+*> = 'L': apply Q or Q**T from the Left;
+*> = 'R': apply Q or Q**T from the Right.
+*>
+*> \param[in] TRANS
+*> TRANS is CHARACTER*1
+*> = 'N': No transpose, apply Q;
+*> = 'T': Transpose, apply Q**T.
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows of the matrix A. M >=0.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of columns of the matrix C. M >= N >= 0.
+*> \endverbatim
+*>
+*> \param[in] K
+*> \verbatim
+*> K is INTEGER
+*> The number of elementary reflectors whose product defines
+*> the matrix Q.
+*> N >= K >= 0;
+*>
+*> \endverbatim
+*>
+*> \param[in] MB
+*> \verbatim
+*> MB is INTEGER
+*> 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.
+*> 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
+*> its array argument A.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A.
+*> If SIDE = 'L', LDA >= max(1,M);
+*> if SIDE = 'R', LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in] T
+*> \verbatim
+*> 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
+*> for further details.
+*> \endverbatim
+*>
+*> \param[in] LDT
+*> \verbatim
+*> LDT is INTEGER
+*> The leading dimension of the array T. LDT >= NB.
+*> \endverbatim
+*>
+*> \param[in,out] C
+*> C is DOUBLE PRECISION array, dimension (LDC,N)
+*> On entry, the M-by-N matrix C.
+*> On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.
+*> \param[in] LDC
+*> LDC is INTEGER
+*> The leading dimension of the array C. LDC >= max(1,M).
+*>
+*> \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
+*> only calculates the optimal size of the WORK array, returns
+*> this value as the first entry of the WORK array, and no error
+*> message related to LWORK is issued by XERBLA.
+*>
+*> \endverbatim
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> < 0: if INFO = -i, the i-th argument had an illegal value
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*> Tall-Skinny QR (TSQR) performs QR by a sequence of orthogonal transformations,
+*> representing Q as a product of other orthogonal matrices
+*> Q = Q(1) * Q(2) * . . . * Q(k)
+*> where each Q(i) zeros out subdiagonal entries of a block of MB rows of A:
+*> Q(1) zeros out the subdiagonal entries of rows 1:MB of A
+*> Q(2) zeros out the bottom MB-N rows of rows [1:N,MB+1:2*MB-N] of A
+*> Q(3) zeros out the bottom MB-N rows of rows [1:N,2*MB-N+1:3*MB-2*N] of A
+*> . . .
+*>
+*> Q(1) is computed by GEQRT, which represents Q(1) by Householder vectors
+*> stored under the diagonal of rows 1:MB of A, and by upper triangular
+*> block reflectors, stored in array T(1:LDT,1:N).
+*> For more information see Further Details in GEQRT.
+*>
+*> Q(i) for i>1 is computed by TPQRT, which represents Q(i) by Householder vectors
+*> stored in rows [(i-1)*(MB-N)+N+1:i*(MB-N)+N] of A, and by upper triangular
+*> 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].
+*>
+*> [1] “Communication-Optimal Parallel and Sequential QR and LU Factorizations,”
+*> J. Demmel, L. Grigori, M. Hoemmen, J. Langou,
+*> SIAM J. Sci. Comput, vol. 34, no. 1, 2012
+*> \endverbatim
+*>
+* =====================================================================
+ 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) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2013
+*
+* .. Scalar Arguments ..
+ CHARACTER SIDE, TRANS
+ INTEGER INFO, LDA, M, N, K, MB, NB, LDT, LWORK, LDC
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), WORK( * ), C(LDC, * ),
+ $ T( LDT, * )
+* ..
+*
+* =====================================================================
+*
+* ..
+* .. Local Scalars ..
+ LOGICAL LEFT, RIGHT, TRAN, NOTRAN, LQUERY
+ INTEGER I, II, KK, LW, CTR
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* .. External Subroutines ..
+ EXTERNAL DGEMQRT, DTPMQRT, XERBLA
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ LQUERY = LWORK.LT.0
+ NOTRAN = LSAME( TRANS, 'N' )
+ TRAN = LSAME( TRANS, 'T' )
+ LEFT = LSAME( SIDE, 'L' )
+ RIGHT = LSAME( SIDE, 'R' )
+ IF (LEFT) THEN
+ LW = N * NB
+ ELSE
+ LW = MB * NB
+ END IF
+*
+ INFO = 0
+ IF( .NOT.LEFT .AND. .NOT.RIGHT ) THEN
+ INFO = -1
+ ELSE IF( .NOT.TRAN .AND. .NOT.NOTRAN ) THEN
+ INFO = -2
+ ELSE IF( M.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( K.LT.0 ) THEN
+ INFO = -5
+ ELSE IF( LDA.LT.MAX( 1, K ) ) THEN
+ INFO = -9
+ ELSE IF( LDT.LT.MAX( 1, NB) ) THEN
+ INFO = -11
+ ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
+ INFO = -13
+ ELSE IF(( LWORK.LT.MAX(1,LW)).AND.(.NOT.LQUERY)) THEN
+ INFO = -15
+ 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( 'DLAMTSQR', -INFO )
+ RETURN
+ ELSE IF (LQUERY) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( MIN(M,N,K).EQ.0 ) THEN
+ RETURN
+ 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)
+ RETURN
+ END IF
+*
+ IF(LEFT.AND.NOTRAN) THEN
+*
+* Multiply Q to the last block of C
+*
+ KK = MOD((M-K),(MB-K))
+ CTR = (M-K)/(MB-K)
+ IF (KK.GT.0) THEN
+ II=M-KK+1
+ CALL DTPMQRT('L','N',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 )
+ ELSE
+ II=M+1
+ END IF
+*
+ DO I=II-(MB-K),MB+1,-(MB-K)
+*
+* Multiply Q to the current block of C (I:I+MB,1:N)
+*
+ CTR = CTR - 1
+ CALL DTPMQRT('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)
+*
+ CALL DGEMQRT('L','N',MB , N, K, NB, A(1,1), LDA, T
+ $ ,LDT ,C(1,1), LDC, WORK, INFO )
+*
+ ELSE IF (LEFT.AND.TRAN) THEN
+*
+* Multiply Q to the first block of C
+*
+ KK = MOD((M-K),(MB-K))
+ II=M-KK+1
+ CTR = 1
+ CALL DGEMQRT('L','T',MB , N, K, NB, A(1,1), LDA, T
+ $ ,LDT ,C(1,1), LDC, WORK, INFO )
+*
+ DO I=MB+1,II-MB+K,(MB-K)
+*
+* Multiply Q to the current block of C (I:I+MB,1:N)
+*
+ CALL DTPMQRT('L','T',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 )
+ CTR = CTR + 1
+*
+ END DO
+ 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
+*
+ ELSE IF(RIGHT.AND.TRAN) THEN
+*
+* Multiply Q to the last block of C
+*
+ KK = MOD((N-K),(MB-K))
+ CTR = (N-K)/(MB-K)
+ IF (KK.GT.0) THEN
+ II=N-KK+1
+ CALL DTPMQRT('R','T',M , KK, K, 0, NB, A(II,1), LDA,
+ $ T(1,CTR*K+1), LDT, C(1,1), LDC,
+ $ C(1,II), LDC, WORK, INFO )
+ ELSE
+ II=N+1
+ END IF
+*
+ DO I=II-(MB-K),MB+1,-(MB-K)
+*
+* Multiply Q to the current block of C (1:M,I:I+MB)
+*
+ CTR = CTR - 1
+ CALL DTPMQRT('R','T',M , MB-K, K, 0,NB, A(I,1), LDA,
+ $ T(1,CTR*K+1), LDT, C(1,1), LDC,
+ $ C(1,I), LDC, WORK, INFO )
+*
+ END DO
+*
+* Multiply Q to the first block of C (1:M,1:MB)
+*
+ CALL DGEMQRT('R','T',M , MB, K, NB, A(1,1), LDA, T
+ $ ,LDT ,C(1,1), LDC, WORK, INFO )
+*
+ ELSE IF (RIGHT.AND.NOTRAN) THEN
+*
+* Multiply Q to the first block of C
+*
+ KK = MOD((N-K),(MB-K))
+ II=N-KK+1
+ CTR = 1
+ CALL DGEMQRT('R','N', M, MB , K, NB, A(1,1), LDA, T
+ $ ,LDT ,C(1,1), LDC, WORK, INFO )
+*
+ DO I=MB+1,II-MB+K,(MB-K)
+*
+* Multiply Q to the current block of C (1:M,I:I+MB)
+*
+ CALL DTPMQRT('R','N', M, MB-K, K, 0,NB, A(I,1), LDA,
+ $ T(1, CTR * K + 1),LDT, C(1,1), LDC,
+ $ C(1,I), LDC, WORK, INFO )
+ CTR = CTR + 1
+*
+ END DO
+ IF(II.LE.N) THEN
+*
+* Multiply Q to the last block of C
+*
+ CALL DTPMQRT('R','N', M, KK , K, 0,NB, A(II,1), LDA,
+ $ T(1, CTR * K + 1),LDT, C(1,1), LDC,
+ $ C(1,II), LDC, WORK, INFO )
+*
+ END IF
+*
+ END IF
+*
+ WORK(1) = LW
+ RETURN
+*
+* End of DLAMTSQR
+*
+ END
\ No newline at end of file
--- /dev/null
+*
+* 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
+*> M-by-N matrix A, where N >= M:
+*> A = L * Q
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows of the matrix A. M >= 0.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of columns of the matrix A. N >= M >= 0.
+*> \endverbatim
+*>
+*> \param[in] MB
+*> \verbatim
+*> MB is INTEGER
+*> 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.
+*> NB > M.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \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
+*> of blocked V (see Further Details).
+*>
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,M).
+*> \endverbatim
+*>
+*> \param[out] T
+*> \verbatim
+*> 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.
+*> See Further Details below.
+*> \endverbatim
+*>
+*> \param[in] LDT
+*> \verbatim
+*> LDT is INTEGER
+*> The leading dimension of the array T. LDT >= MB.
+*> \endverbatim
+*>
+*>
+*> \param[out] WORK
+*> \verbatim
+*> (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+*>
+*> \endverbatim
+*> \param[in] LWORK
+*> \verbatim
+*> The dimension of the array WORK. LWORK >= MB*M.
+*> If LWORK = -1, then a workspace query is assumed; the routine
+*> only calculates the optimal size of the WORK array, returns
+*> this value as the first entry of the WORK array, and no error
+*> message related to LWORK is issued by XERBLA.
+*>
+*> \endverbatim
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> < 0: if INFO = -i, the i-th argument had an illegal value
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*> Short-Wide LQ (SWLQ) performs LQ by a sequence of orthogonal transformations,
+*> representing Q as a product of other orthogonal matrices
+*> Q = Q(1) * Q(2) * . . . * Q(k)
+*> where each Q(i) zeros out upper diagonal entries of a block of NB rows of A:
+*> Q(1) zeros out the upper diagonal entries of rows 1:NB of A
+*> Q(2) zeros out the bottom MB-N rows of rows [1:M,NB+1:2*NB-M] of A
+*> Q(3) zeros out the bottom MB-N rows of rows [1:M,2*NB-M+1:3*NB-2*M] of A
+*> . . .
+*>
+*> Q(1) is computed by GELQT, which represents Q(1) by Householder vectors
+*> stored under the diagonal of rows 1:MB of A, and by upper triangular
+*> block reflectors, stored in array T(1:LDT,1:N).
+*> For more information see Further Details in GELQT.
+*>
+*> Q(i) for i>1 is computed by TPLQT, which represents Q(i) by Householder vectors
+*> stored in columns [(i-1)*(NB-M)+M+1:i*(NB-M)+M] of A, and by upper triangular
+*> 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].
+*>
+*> [1] “Communication-Optimal Parallel and Sequential QR and LU Factorizations,”
+*> J. Demmel, L. Grigori, M. Hoemmen, J. Langou,
+*> SIAM J. Sci. Comput, vol. 34, no. 1, 2012
+*> \endverbatim
+*>
+* =====================================================================
+ SUBROUTINE DLASWLQ( M, N, MB, NB, A, LDA, T, LDT, WORK, LWORK,
+ $ INFO)
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd. --
+* November 2013
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, M, N, MB, NB, LWORK, LDT
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), WORK( * ), T( LDT, *)
+* ..
+*
+* =====================================================================
+*
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY
+ INTEGER I, II, KK, CTR
+* ..
+* .. EXTERNAL FUNCTIONS ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* .. EXTERNAL SUBROUTINES ..
+ EXTERNAL DGELQT, DTPLQT, XERBLA
+* .. INTRINSIC FUNCTIONS ..
+ INTRINSIC MAX, MIN, MOD
+* ..
+* .. EXECUTABLE STATEMENTS ..
+*
+* TEST THE INPUT ARGUMENTS
+*
+ INFO = 0
+*
+ LQUERY = ( LWORK.EQ.-1 )
+*
+ IF( M.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 .OR. N.LT.M ) THEN
+ INFO = -2
+ ELSE IF( MB.LT.1 .OR. ( MB.GT.M .AND. M.GT.0 )) THEN
+ INFO = -3
+ ELSE IF( NB.LE.M ) THEN
+ INFO = -4
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -5
+ 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
+ WORK(1) = MB*M
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DLASWLQ', -INFO )
+ RETURN
+ ELSE IF (LQUERY) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( MIN(M,N).EQ.0 ) THEN
+ RETURN
+ END IF
+*
+* The LQ Decomposition
+*
+ 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
+*
+ KK = MOD((N-M),(NB-M))
+ II=N-KK+1
+*
+* Compute the LQ factorization of the first block A(1:M,1:NB)
+*
+ CALL DGELQT( M, NB, MB, A(1,1), LDA, T, LDT, WORK, INFO)
+ 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 ),
+ $ LDA, T(1, CTR * M + 1),
+ $ LDT, WORK, INFO )
+ CTR = CTR + 1
+ END DO
+*
+* Compute the QR factorization of the last block A(1:M,II:N)
+*
+ IF (II.LE.N) THEN
+ CALL DTPLQT( M, KK, 0, MB, A(1,1), LDA, A( 1, II ),
+ $ LDA, T(1, CTR * M + 1), LDT,
+ $ WORK, INFO )
+ END IF
+*
+ WORK( 1 ) = M * MB
+ RETURN
+*
+* End of DLASWLQ
+*
+ END
\ No newline at end of file
--- /dev/null
+*
+* Definition:
+* ===========
+*
+* 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
+*> an M-by-N matrix A, where M >= N:
+*> A = Q * R .
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows of the matrix A. M >= 0.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of columns of the matrix A. M >= N >= 0.
+*> \endverbatim
+*>
+*> \param[in] MB
+*> \verbatim
+*> MB is INTEGER
+*> 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.
+*> N >= NB >= 1.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \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
+*> of blocked V (see Further Details).
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,M).
+*> \endverbatim
+*>
+*> \param[out] T
+*> \verbatim
+*> 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.
+*> See Further Details below.
+*> \endverbatim
+*>
+*> \param[in] LDT
+*> \verbatim
+*> LDT is INTEGER
+*> The leading dimension of the array T. LDT >= NB.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+*> \endverbatim
+*>
+*> \param[in] LWORK
+*> \verbatim
+*> The dimension of the array WORK. LWORK >= NB*N.
+*> If LWORK = -1, then a workspace query is assumed; the routine
+*> only calculates the optimal size of the WORK array, returns
+*> this value as the first entry of the WORK array, and no error
+*> message related to LWORK is issued by XERBLA.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> < 0: if INFO = -i, the i-th argument had an illegal value
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*> Tall-Skinny QR (TSQR) performs QR by a sequence of orthogonal transformations,
+*> representing Q as a product of other orthogonal matrices
+*> Q = Q(1) * Q(2) * . . . * Q(k)
+*> where each Q(i) zeros out subdiagonal entries of a block of MB rows of A:
+*> Q(1) zeros out the subdiagonal entries of rows 1:MB of A
+*> Q(2) zeros out the bottom MB-N rows of rows [1:N,MB+1:2*MB-N] of A
+*> Q(3) zeros out the bottom MB-N rows of rows [1:N,2*MB-N+1:3*MB-2*N] of A
+*> . . .
+*>
+*> Q(1) is computed by GEQRT, which represents Q(1) by Householder vectors
+*> stored under the diagonal of rows 1:MB of A, and by upper triangular
+*> block reflectors, stored in array T(1:LDT,1:N).
+*> For more information see Further Details in GEQRT.
+*>
+*> Q(i) for i>1 is computed by TPQRT, which represents Q(i) by Householder vectors
+*> stored in rows [(i-1)*(MB-N)+N+1:i*(MB-N)+N] of A, and by upper triangular
+*> 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].
+*>
+*> [1] “Communication-Optimal Parallel and Sequential QR and LU Factorizations,”
+*> J. Demmel, L. Grigori, M. Hoemmen, J. Langou,
+*> SIAM J. Sci. Comput, vol. 34, no. 1, 2012
+*> \endverbatim
+*>
+* =====================================================================
+ SUBROUTINE DLATSQR( M, N, MB, NB, A, LDA, T, LDT, WORK,
+ $ LWORK, INFO)
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd. --
+* November 2013
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, M, N, MB, NB, LDT, LWORK
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), WORK( * ), T(LDT, *)
+* ..
+*
+* =====================================================================
+*
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY
+ INTEGER I, II, KK, CTR
+* ..
+* .. EXTERNAL FUNCTIONS ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* .. EXTERNAL SUBROUTINES ..
+ EXTERNAL DGEQRT, DTPQRT, XERBLA
+* .. INTRINSIC FUNCTIONS ..
+ INTRINSIC MAX, MIN, MOD
+* ..
+* .. EXECUTABLE STATEMENTS ..
+*
+* TEST THE INPUT ARGUMENTS
+*
+ INFO = 0
+*
+ LQUERY = ( LWORK.EQ.-1 )
+*
+ IF( M.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 .OR. M.LT.N ) THEN
+ INFO = -2
+ ELSE IF( MB.LE.N ) THEN
+ 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
+ INFO = -5
+ ELSE IF( LDT.LT.NB ) THEN
+ INFO = -8
+ ELSE IF( LWORK.LT.(N*NB) .AND. (.NOT.LQUERY) ) THEN
+ INFO = -10
+ END IF
+ IF( INFO.EQ.0) THEN
+ WORK(1) = NB*N
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DLATSQR', -INFO )
+ RETURN
+ ELSE IF (LQUERY) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( MIN(M,N).EQ.0 ) THEN
+ RETURN
+ END IF
+*
+* The QR Decomposition
+*
+ IF ((MB.LE.N).OR.(MB.GE.M)) THEN
+ CALL DGEQRT( M, N, NB, A, LDA, T, LDT, WORK, INFO)
+ RETURN
+ END IF
+*
+ KK = MOD((M-N),(MB-N))
+ II=M-KK+1
+*
+* Compute the QR factorization of the first block A(1:MB,1:N)
+*
+ CALL DGEQRT( MB, N, NB, A(1,1), LDA, T, LDT, WORK, INFO )
+*
+ 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,
+ $ T(1, CTR * N + 1),
+ $ LDT, WORK, INFO )
+ CTR = CTR + 1
+ END DO
+*
+* Compute the QR factorization of the last block A(II:M,1:N)
+*
+ IF (II.LE.M) THEN
+ CALL DTPQRT( KK, N, 0, NB, A(1,1), LDA, A( II, 1 ), LDA,
+ $ T(1, CTR * N + 1), LDT,
+ $ WORK, INFO )
+ END IF
+*
+ WORK( 1 ) = N*NB
+ RETURN
+*
+* End of DLATSQR
+*
+ END
\ No newline at end of file
--- /dev/null
+*> \brief \b DTPLQT
+*
+* =========== DOCUMENTATION ===========
+*
+* 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">
+*> [TXT]</a>
+*> \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
+*> WY representation for Q.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows of the matrix B, and the order of the
+*> triangular matrix A.
+*> M >= 0.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of columns of the matrix B.
+*> N >= 0.
+*> \endverbatim
+*>
+*> \param[in] L
+*> \verbatim
+*> L is INTEGER
+*> The number of rows of the lower trapezoidal part of B.
+*> MIN(M,N) >= L >= 0. See Further Details.
+*> \endverbatim
+*>
+*> \param[in] MB
+*> \verbatim
+*> MB is INTEGER
+*> The block size to be used in the blocked QR. M >= MB >= 1.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is DOUBLE PRECISION array, dimension (LDA,N)
+*> On entry, the lower triangular N-by-N matrix A.
+*> On exit, the elements on and below the diagonal of the array
+*> contain the lower triangular matrix L.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in,out] B
+*> \verbatim
+*> B is DOUBLE PRECISION array, dimension (LDB,N)
+*> On entry, the 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
+*>
+*> \param[in] LDB
+*> \verbatim
+*> LDB is INTEGER
+*> The leading dimension of the array B. LDB >= max(1,M).
+*> \endverbatim
+*>
+*> \param[out] T
+*> \verbatim
+*> T is DOUBLE PRECISION array, dimension (LDT,N)
+*> 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
+*> The leading dimension of the array T. LDT >= MB.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is DOUBLE PRECISION array, dimension (MB*M)
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> < 0: if INFO = -i, the i-th argument had an illegal value
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2013
+*
+*> \ingroup doubleOTHERcomputational
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*>
+*> 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 ]
+*> [ 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.
+*>
+*> 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 ]
+*> [ A ] <- lower triangular N-by-N
+*> [ B ] <- M-by-N pentagonal
+*>
+*> so that W can be represented as
+*> [ 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 ]
+*> [ 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 number of blocks is B = ceiling(M/MB), where each
+*> 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
+*> for the last block) T's are stored in the MB-by-N matrix T as
+*>
+*> T = [T1 T2 ... TB].
+*> \endverbatim
+*>
+* =====================================================================
+ SUBROUTINE DTPLQT( M, N, L, MB, A, LDA, B, LDB, T, LDT, WORK,
+ $ INFO )
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2013
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, LDB, LDT, N, M, L, MB
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), B( LDB, * ), T( LDT, * ), WORK( * )
+* ..
+*
+* =====================================================================
+*
+* ..
+* .. Local Scalars ..
+ INTEGER I, IB, LB, NB, IINFO
+* ..
+* .. External Subroutines ..
+ EXTERNAL DTPLQT2, DTPRFB, XERBLA
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+ IF( M.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( L.LT.0 .OR. (L.GT.MIN(M,N) .AND. MIN(M,N).GE.0)) THEN
+ INFO = -3
+ ELSE IF( MB.LT.1 .OR. (MB.GT.M .AND. M.GT.0)) THEN
+ INFO = -4
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -6
+ ELSE IF( LDB.LT.MAX( 1, M ) ) THEN
+ INFO = -8
+ ELSE IF( LDT.LT.MB ) THEN
+ INFO = -10
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DTPLQT', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ 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 )
+ NB = MIN( N-L+I+IB-1, N )
+ IF( I.GE.L ) THEN
+ LB = 0
+ ELSE
+ LB = NB-N+L-I+1
+ END IF
+*
+ 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,
+ $ WORK, M-I-IB+1)
+ END IF
+ END DO
+ RETURN
+*
+* End of DTPLQT
+*
+ END
--- /dev/null
+*> \brief \b DTPLQT2 computes a LQ factorization of a real or complex "triangular-pentagonal" matrix, which is composed of a triangular block and a pentagonal block, using the compact WY representation for Q.
+*
+* =========== DOCUMENTATION ===========
+*
+* 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">
+*> [TXT]</a>
+*> \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,
+*> using the compact WY representation for Q.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The total number of rows of the matrix B.
+*> M >= 0.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of columns of the matrix B, and the order of
+*> the triangular matrix A.
+*> N >= 0.
+*> \endverbatim
+*>
+*> \param[in] L
+*> \verbatim
+*> L is INTEGER
+*> The number of rows of the lower trapezoidal part of B.
+*> MIN(M,N) >= L >= 0. See Further Details.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is DOUBLE PRECISION array, dimension (LDA,N)
+*> On entry, the lower triangular M-by-M matrix A.
+*> On exit, the elements on and below the diagonal of the array
+*> contain the lower triangular matrix L.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in,out] B
+*> \verbatim
+*> B is DOUBLE PRECISION array, dimension (LDB,N)
+*> On entry, the 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
+*>
+*> \param[in] LDB
+*> \verbatim
+*> LDB is INTEGER
+*> The leading dimension of the array B. LDB >= max(1,M).
+*> \endverbatim
+*>
+*> \param[out] T
+*> \verbatim
+*> T is DOUBLE PRECISION array, dimension (LDT,M)
+*> The N-by-N upper triangular factor T of the block reflector.
+*> See Further Details.
+*> \endverbatim
+*>
+*> \param[in] LDT
+*> \verbatim
+*> LDT is INTEGER
+*> The leading dimension of the array T. LDT >= max(1,M)
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> < 0: if INFO = -i, the i-th argument had an illegal value
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date September 2012
+*
+*> \ingroup doubleOTHERcomputational
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*>
+*> 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
+*> upper trapezoidal matrix B2:
+*>
+*> B = [ B1 ][ B2 ]
+*> [ B1 ] <- M-by-(N-L) rectangular
+*> [ 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.
+*>
+*> 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 ]
+*> [ A ] <- lower triangular N-by-N
+*> [ B ] <- M-by-N pentagonal
+*>
+*> so that W can be represented as
+*>
+*> 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,
+*>
+*> 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 (M+N)-by-(M+N) block reflector H is then given by
+*>
+*> H = I - W**T * T * W
+*>
+*> where W^H is the conjugate transpose of W and T is the upper triangular
+*> factor of the block reflector.
+*> \endverbatim
+*>
+* =====================================================================
+ SUBROUTINE DTPLQT2( M, N, L, A, LDA, B, LDB, T, LDT, INFO )
+*
+* -- LAPACK computational routine (version 3.4.2) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* September 2012
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, LDB, LDT, N, M, L
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), B( LDB, * ), T( LDT, * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE, ZERO
+ PARAMETER( ONE = 1.0, ZERO = 0.0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, J, P, MP, NP
+ DOUBLE PRECISION ALPHA
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLARFG, DGEMV, DGER, DTRMV, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+ IF( M.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( L.LT.0 .OR. L.GT.MIN(M,N) ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -5
+ ELSE IF( LDB.LT.MAX( 1, M ) ) THEN
+ INFO = -7
+ ELSE IF( LDT.LT.MAX( 1, M ) ) THEN
+ INFO = -9
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DTPLQT2', -INFO )
+ RETURN
+ END IF
+*
+* 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,:)
+*
+ P = N-L+MIN( L, I )
+ CALL DLARFG( P+1, A( I, I ), B( I, 1 ), LDB, T( 1, I ) )
+ IF( I.LT.M ) THEN
+*
+* W(M-I:1) := C(I+1:M,I:N) * C(I,I:N) [use W = T(M,:)]
+*
+ 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,
+ $ 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 ))
+ DO J = 1, M-I
+ A( I+J, I ) = A( I+J, I ) + ALPHA*(T( M, J ))
+ END DO
+ CALL DGER( M-I, P, ALPHA, T( M, 1 ), LDT,
+ $ B( I, 1 ), LDB, B( I+1, 1 ), LDB )
+ END IF
+ END DO
+*
+ DO I = 2, M
+*
+* T(I,1:I-1) := C(I:I-1,1:N) * (alpha * C(I,I:N)^H)
+*
+ ALPHA = -T( 1, I )
+
+ DO J = 1, I-1
+ T( I, J ) = ZERO
+ END DO
+ P = MIN( I-1, L )
+ NP = MIN( N-L+1, N )
+ MP = MIN( P+1, M )
+*
+* Triangular part of B2
+*
+ DO J = 1, P
+ T( I, J ) = ALPHA*B( I, N-L+J )
+ END DO
+ CALL DTRMV( 'L', 'N', 'N', P, B( 1, NP ), LDB,
+ $ T( I, 1 ), LDT )
+*
+* Rectangular part of B2
+*
+ 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 )
+*
+* T(1:I-1,I) := T(1:I-1,1:I-1) * T(I,1:I-1)
+*
+ CALL DTRMV( 'L', 'T', 'N', I-1, T, LDT, T( I, 1 ), LDT )
+*
+* T(I,I) = tau(I)
+*
+ T( I, I ) = T( 1, I )
+ T( 1, I ) = ZERO
+ END DO
+ DO I=1,M
+ DO J= I+1,M
+ T(I,J)=T(J,I)
+ T(J,I)= ZERO
+ END DO
+ END DO
+
+*
+* End of DTPLQT2
+*
+ END
--- /dev/null
+*> \brief \b DTPMLQT
+*
+* =========== DOCUMENTATION ===========
+*
+* 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">
+*> [TXT]</a>
+*> \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, * ),
+* $ T( LDT, * ), WORK( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> 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
+*
+* Arguments:
+* ==========
+*
+*> \param[in] SIDE
+*> \verbatim
+*> SIDE is CHARACTER*1
+*> = 'L': apply Q or Q**T from the Left;
+*> = 'R': apply Q or Q**T from the Right.
+*> \endverbatim
+*>
+*> \param[in] TRANS
+*> \verbatim
+*> TRANS is CHARACTER*1
+*> = 'N': No transpose, apply Q;
+*> = 'T': Transpose, apply Q**T.
+*> \endverbatim
+*>
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows of the matrix B. M >= 0.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of columns of the matrix B. N >= 0.
+*> \endverbatim
+*>
+*> \param[in] K
+*> \verbatim
+*> K is INTEGER
+*> The number of elementary reflectors whose product defines
+*> the matrix Q.
+*> \endverbatim
+*>
+*> \param[in] L
+*> \verbatim
+*> L is INTEGER
+*> The order of the trapezoidal part of V.
+*> K >= L >= 0. See Further Details.
+*> \endverbatim
+*>
+*> \param[in] MB
+*> \verbatim
+*> MB is INTEGER
+*> The block size used for the storage of T. K >= MB >= 1.
+*> This must be the same value of MB used to generate T
+*> in DTPLQT.
+*> \endverbatim
+*>
+*> \param[in] V
+*> \verbatim
+*> V is DOUBLE PRECISION array, dimension (LDA,K)
+*> The i-th row must contain the vector which defines the
+*> elementary reflector H(i), for i = 1,2,...,k, as returned by
+*> DTPLQT in B. See Further Details.
+*> \endverbatim
+*>
+*> \param[in] LDV
+*> \verbatim
+*> LDV is INTEGER
+*> The leading dimension of the array V.
+*> If SIDE = 'L', LDV >= max(1,M);
+*> if SIDE = 'R', LDV >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in] T
+*> \verbatim
+*> T is DOUBLE PRECISION array, dimension (LDT,K)
+*> The upper triangular factors of the block reflectors
+*> as returned by DTPLQT, stored as a MB-by-K matrix.
+*> \endverbatim
+*>
+*> \param[in] LDT
+*> \verbatim
+*> LDT is INTEGER
+*> The leading dimension of the array T. LDT >= MB.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is DOUBLE PRECISION array, dimension
+*> (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
+*> 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.
+*> If SIDE = 'L', LDC >= max(1,K);
+*> If SIDE = 'R', LDC >= max(1,M).
+*> \endverbatim
+*>
+*> \param[in,out] B
+*> \verbatim
+*> B is DOUBLE PRECISION array, dimension (LDB,N)
+*> On entry, the M-by-N matrix B.
+*> On exit, B 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] LDB
+*> \verbatim
+*> LDB is INTEGER
+*> The leading dimension of the array B.
+*> LDB >= max(1,M).
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is DOUBLE PRECISION array. The dimension of WORK is
+*> N*MB if SIDE = 'L', or M*MB if SIDE = 'R'.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> < 0: if INFO = -i, the i-th argument had an illegal value
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2015
+*
+*> \ingroup doubleOTHERcomputational
+*
+*> \par Further Details:
+* =====================
+*>
+*> \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
+*> trapezoidal block V2:
+*>
+*> V = [V1] [V2].
+*>
+*>
+*> 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 = '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.
+*>
+*> If TRANS='N' and SIDE='L', C is on exit replaced with Q * C.
+*>
+*> If TRANS='T' and SIDE='L', C is on exit replaced with Q**T * C.
+*>
+*> If TRANS='N' and SIDE='R', C is on exit replaced with C * Q.
+*>
+*> If TRANS='T' and SIDE='R', C is on exit replaced with C * Q**T.
+*> \endverbatim
+*>
+* =====================================================================
+ SUBROUTINE DTPMLQT( SIDE, TRANS, M, N, K, L, MB, V, LDV, T, LDT,
+ $ A, LDA, B, LDB, WORK, INFO )
+*
+* -- LAPACK computational routine (version 3.6.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2015
+*
+* .. 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, * ),
+ $ T( LDT, * ), WORK( * )
+* ..
+*
+* =====================================================================
+*
+* ..
+* .. Local Scalars ..
+ LOGICAL LEFT, RIGHT, TRAN, NOTRAN
+ INTEGER I, IB, NB, LB, KF, LDAQ
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL XERBLA, DLARFB
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* .. Test the input arguments ..
+*
+ INFO = 0
+ LEFT = LSAME( SIDE, 'L' )
+ RIGHT = LSAME( SIDE, 'R' )
+ TRAN = LSAME( TRANS, 'T' )
+ NOTRAN = LSAME( TRANS, 'N' )
+*
+ IF ( LEFT ) THEN
+ LDAQ = MAX( 1, K )
+ ELSE IF ( RIGHT ) THEN
+ LDAQ = MAX( 1, M )
+ END IF
+ IF( .NOT.LEFT .AND. .NOT.RIGHT ) THEN
+ INFO = -1
+ ELSE IF( .NOT.TRAN .AND. .NOT.NOTRAN ) THEN
+ INFO = -2
+ ELSE IF( M.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( K.LT.0 ) THEN
+ INFO = -5
+ ELSE IF( L.LT.0 .OR. L.GT.K ) THEN
+ INFO = -6
+ ELSE IF( MB.LT.1 .OR. (MB.GT.K .AND. K.GT.0) ) THEN
+ INFO = -7
+ ELSE IF( LDV.LT.K ) THEN
+ INFO = -9
+ ELSE IF( LDT.LT.MB ) THEN
+ INFO = -11
+ ELSE IF( LDA.LT.LDAQ ) THEN
+ INFO = -13
+ ELSE IF( LDB.LT.MAX( 1, M ) ) THEN
+ INFO = -15
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DTPMLQT', -INFO )
+ RETURN
+ END IF
+*
+* .. Quick return if possible ..
+*
+ IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) RETURN
+*
+ IF( LEFT .AND. NOTRAN ) THEN
+*
+ DO I = 1, K, MB
+ 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
+ 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
+ IB = MIN( MB, K-I+1 )
+ NB = MIN( N-L+I+IB-1, N )
+ IF( I.GE.L ) THEN
+ LB = 0
+ 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,
+ $ A( 1, I ), LDA, B, LDB, WORK, M )
+ END DO
+*
+ ELSE IF( LEFT .AND. TRAN ) THEN
+*
+ KF = ((K-1)/MB)*MB+1
+ DO I = KF, 1, -MB
+ 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
+ CALL DTPRFB( 'L', 'N', '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. NOTRAN ) THEN
+*
+ KF = ((K-1)/MB)*MB+1
+ DO I = KF, 1, -MB
+ IB = MIN( MB, K-I+1 )
+ NB = MIN( N-L+I+IB-1, N )
+ IF( I.GE.L ) THEN
+ LB = 0
+ ELSE
+ 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,
+ $ A( 1, I ), LDA, B, LDB, WORK, M )
+ END DO
+*
+ END IF
+*
+ RETURN
+*
+* End of DTPMLQT
+*
+ 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 ILAENV + dependencies
-*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ilaenv.f">
-*> [TGZ]</a>
-*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ilaenv.f">
-*> [ZIP]</a>
-*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ilaenv.f">
+*> Download ILAENV + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ilaenv.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ilaenv.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ilaenv.f">
*> [TXT]</a>
-*> \endhtmlonly
+*> \endhtmlonly
*
* Definition:
* ===========
*
* INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, N4 )
-*
+*
* .. Scalar Arguments ..
* CHARACTER*( * ) NAME, OPTS
* INTEGER ISPEC, N1, N2, N3, N4
* ..
-*
+*
*
*> \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 June 2016
+*> \date November 2015
*
-*> \ingroup OTHERauxiliary
+*> \ingroup auxOTHERauxiliary
*
*> \par Further Details:
* =====================
* =====================================================================
INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, N4 )
*
-* -- LAPACK auxiliary routine (version 3.6.1) --
+* -- LAPACK auxiliary routine (version 3.6.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* June 2016
+* November 2015
*
* .. Scalar Arguments ..
CHARACTER*( * ) NAME, OPTS
ELSE
NB = 32
END IF
+ ELSE IF( C3.EQ.'QR ') THEN
+ IF( N3 .EQ. 1) THEN
+ IF( SNAME ) THEN
+ IF ((M*N.LE.131072).OR.(M.LE.8192)) THEN
+ NB = N1
+ ELSE
+ NB = 32768/N2
+ END IF
+ ELSE
+ IF ((M*N.LE.131072).OR.(M.LE.8192)) THEN
+ NB = N1
+ ELSE
+ NB = 32768/N2
+ END IF
+ END IF
+ ELSE
+ IF( SNAME ) THEN
+ NB = 1
+ ELSE
+ NB = 1
+ END IF
+ END IF
+ ELSE IF( C3.EQ.'LQ ') THEN
+ IF( N3 .EQ. 2) THEN
+ IF( SNAME ) THEN
+ IF ((M*N.LE.131072).OR.(M.LE.8192)) THEN
+ NB = N1
+ ELSE
+ NB = 32768/N2
+ END IF
+ ELSE
+ IF ((M*N.LE.131072).OR.(M.LE.8192)) THEN
+ NB = N1
+ ELSE
+ NB = 32768/N2
+ END IF
+ END IF
+ ELSE
+ IF( SNAME ) THEN
+ NB = 1
+ ELSE
+ NB = 1
+ END IF
+ END IF
ELSE IF( C3.EQ.'HRD' ) THEN
IF( SNAME ) THEN
NB = 32
ELSE
NB = 64
END IF
- ELSE IF ( C3.EQ.'EVC' ) THEN
- IF( SNAME ) THEN
- NB = 64
- ELSE
- NB = 64
- END IF
END IF
ELSE IF( C2.EQ.'LA' ) THEN
IF( C3.EQ.'UUM' ) THEN
--- /dev/null
+*
+* Definition:
+* ===========
+*
+* 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:
+*> A = L * Q .
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows of the matrix A. M >= 0.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of columns of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is 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
+*> (L is lower triangular if M <= N);
+*> the elements above the diagonal are the rows of
+*> blocked V representing Q (see Further Details).
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,M).
+*> \endverbatim
+*>
+*> \param[out] WORK1
+*> \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
+*> 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
+*> SLASWLQ or SGELQT
+*> \endverbatim
+*>
+*> \param[in] LWORK1
+*> \verbatim
+*> LWORK1 is INTEGER
+*> The dimension of the array WORK1.
+*> 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
+*> 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
+*> 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
+*> LWORK2 = -1.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> < 0: if INFO = -i, the i-th argument had an illegal value
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*> 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 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
+*> 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
+*> Further Details in LASWLQ or GELQT.
+*> \endverbatim
+*>
+*>
+* =====================================================================
+ SUBROUTINE SGELQ( M, N, A, LDA, WORK1, LWORK1, WORK2, LWORK2,
+ $ INFO)
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd. --
+* November 2013
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, M, N, LWORK1, LWORK2
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * ), WORK1( * ), WORK2( * )
+* ..
+*
+* =====================================================================
+*
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY, LMINWS
+ INTEGER MB, NB, I, II, KK, MINLW1, NBLCKS
+* ..
+* .. EXTERNAL FUNCTIONS ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* .. EXTERNAL SUBROUTINES ..
+ EXTERNAL SGELQT, SLASWLQ, XERBLA
+* .. INTRINSIC FUNCTIONS ..
+ INTRINSIC MAX, MIN, MOD
+* ..
+* .. EXTERNAL FUNCTIONS ..
+ INTEGER ILAENV
+ EXTERNAL ILAENV
+* ..
+* .. EXECUTABLE STATEMENTS ..
+*
+* TEST THE INPUT ARGUMENTS
+*
+ INFO = 0
+*
+ LQUERY = ( LWORK1.EQ.-1 .OR. LWORK2.EQ.-1 )
+*
+* 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)
+ ELSE
+ MB = 1
+ NB = N
+ END IF
+ IF( MB.GT.MIN(M,N).OR.MB.LT.1) MB = 1
+ IF( NB.GT.N.OR.NB.LE.M) NB = N
+ MINLW1 = M + 5
+ IF ((NB.GT.M).AND.(N.GT.M)) THEN
+ IF(MOD(N-M, NB-M).EQ.0) THEN
+ NBLCKS = (N-M)/(NB-M)
+ ELSE
+ NBLCKS = (N-M)/(NB-M) + 1
+ END IF
+ ELSE
+ NBLCKS = 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)
+ $ .AND.(.NOT.LQUERY)) THEN
+ IF (LWORK1.LT.MAX(1,MB*M*NBLCKS+5)) THEN
+ LMINWS = .TRUE.
+ MB = 1
+ END IF
+ IF (LWORK1.LT.MAX(1,M*NBLCKS+5)) THEN
+ LMINWS = .TRUE.
+ NB = N
+ END IF
+ IF (LWORK2.LT.MB*M) THEN
+ LMINWS = .TRUE.
+ MB = 1
+ END IF
+ END IF
+*
+ IF( M.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -4
+ 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
+*
+ IF( INFO.EQ.0) THEN
+ WORK1(1) = 1
+ WORK1(2) = MB*M*NBLCKS+5
+ WORK1(3) = MINLW1
+ WORK1(4) = MB
+ WORK1(5) = NB
+ WORK2(1) = MB * M
+ WORK2(2) = M
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SGELQ', -INFO )
+ RETURN
+ ELSE IF (LQUERY) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( MIN(M,N).EQ.0 ) THEN
+ RETURN
+ END IF
+*
+* The LQ Decomposition
+*
+ 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,
+ $ LWORK2, INFO)
+ END IF
+ RETURN
+*
+* End of SGELQ
+*
+ END
\ No newline at end of file
--- /dev/null
+* Definition:
+* ===========
+*
+* 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.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows of the matrix A. M >= 0.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of columns of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in] MB
+*> \verbatim
+*> MB is INTEGER
+*> The block size to be used in the blocked QR. MIN(M,N) >= MB >= 1.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \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 (L is
+*> lower triangular if M <= N); the elements above the diagonal
+*> are the rows of V.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,M).
+*> \endverbatim
+*>
+*> \param[out] T
+*> \verbatim
+*> T is REAL array, dimension (LDT,MIN(M,N))
+*> The upper triangular block reflectors stored in compact form
+*> as a sequence of upper triangular blocks. See below
+*> for further details.
+*> \endverbatim
+*>
+*> \param[in] LDT
+*> \verbatim
+*> LDT is INTEGER
+*> The leading dimension of the array T. LDT >= MB.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is REAL array, dimension (MB*N)
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> < 0: if INFO = -i, the i-th argument had an illegal value
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2013
+*
+*> \ingroup doubleGEcomputational
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*>
+*> The matrix V stores the elementary reflectors H(i) in the i-th column
+*> below the diagonal. For example, if M=5 and N=3, the matrix V is
+*>
+*> 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.
+*> 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
+*> 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
+*> for the last block) T's are stored in the NB-by-N matrix T as
+*>
+*> T = (T1 T2 ... TB).
+*> \endverbatim
+*>
+* =====================================================================
+ SUBROUTINE SGELQT( M, N, MB, A, LDA, T, LDT, WORK, INFO )
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2013
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, LDT, M, N, MB
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * ), T( LDT, * ), WORK( * )
+* ..
+*
+* =====================================================================
+*
+* ..
+* .. Local Scalars ..
+ INTEGER I, IB, IINFO, K
+* ..
+* .. External Subroutines ..
+ EXTERNAL SGEQRT2, SGEQRT3, SLARFB, XERBLA
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+ IF( M.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( MB.LT.1 .OR. ( MB.GT.MIN(M,N) .AND. MIN(M,N).GT.0 ) )THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -5
+ ELSE IF( LDT.LT.MB ) THEN
+ INFO = -7
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SGELQT', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ K = MIN( M, N )
+ IF( K.EQ.0 ) RETURN
+*
+* Blocked loop of length K
+*
+ 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+IB, I ), LDA, WORK , M-I-IB+1 )
+ END IF
+ END DO
+ RETURN
+*
+* End of SGELQT
+*
+ END
--- /dev/null
+* Definition:
+* ===========
+*
+* 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.
+*>
+*> Based on the algorithm of Elmroth and Gustavson,
+*> IBM J. Res. Develop. Vol 44 No. 4 July 2000.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows of the matrix A. M =< N.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of columns of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is REAL array, dimension (LDA,N)
+*> On entry, the real M-by-N matrix A. On exit, the elements on and
+*> below the diagonal contain the N-by-N lower triangular matrix L; the
+*> elements above the diagonal are the rows of V. See below for
+*> further details.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,M).
+*> \endverbatim
+*>
+*> \param[out] T
+*> \verbatim
+*> T is REAL array, dimension (LDT,N)
+*> The N-by-N upper triangular factor of the block reflector.
+*> The elements on and above the diagonal contain the block
+*> reflector T; the elements below the diagonal are not used.
+*> See below for further details.
+*> \endverbatim
+*>
+*> \param[in] LDT
+*> \verbatim
+*> LDT is INTEGER
+*> The leading dimension of the array T. LDT >= max(1,N).
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> < 0: if INFO = -i, the i-th argument had an illegal value
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date September 2012
+*
+*> \ingroup doubleGEcomputational
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*>
+*> The matrix V stores the elementary reflectors H(i) in the i-th column
+*> below the diagonal. For example, if M=5 and N=3, the matrix V is
+*>
+*> 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
+*> block reflector H is then given by
+*>
+*> H = I - V * T * V**T
+*>
+*> where V**T is the transpose of V.
+*>
+*> For details of the algorithm, see Elmroth and Gustavson (cited above).
+*> \endverbatim
+*>
+* =====================================================================
+ RECURSIVE SUBROUTINE SGELQT3( M, N, A, LDA, T, LDT, INFO )
+*
+* -- LAPACK computational routine (version 3.4.2) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* September 2012
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, M, N, LDT
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * ), T( LDT, * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE
+ PARAMETER ( ONE = 1.0D+00 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, I1, J, J1, N1, N2, IINFO
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLARFG, DTRMM, DGEMM, XERBLA
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+ IF( M .LT. 0 ) THEN
+ INFO = -1
+ ELSE IF( N .LT. M ) THEN
+ INFO = -2
+ ELSE IF( LDA .LT. MAX( 1, M ) ) THEN
+ INFO = -4
+ ELSE IF( LDT .LT. MAX( 1, M ) ) THEN
+ INFO = -6
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SGELQT3', -INFO )
+ RETURN
+ END IF
+*
+ IF( M.EQ.1 ) THEN
+*
+* Compute Householder transform when N=1
+*
+ CALL SLARFG( N, A, A( 1, MIN( 2, N ) ), LDA, T )
+*
+ ELSE
+*
+* Otherwise, split A into blocks...
+*
+ M1 = M/2
+ M2 = M-M1
+ I1 = MIN( M1+1, M )
+ J1 = MIN( M+1, N )
+*
+* Compute A(1:M1,1:N) <- (Y1,R1,T1), where Q1 = I - Y1 T1 Y1^H
+*
+ CALL SGELQT3( M1, N, A, LDA, T, LDT, IINFO )
+*
+* Compute A(J1:M,1:N) = Q1^H A(J1:M,1:N) [workspace: T(1:N1,J1:N)]
+*
+ DO I=1,M2
+ DO J=1,M1
+ T( I+M1, J ) = A( I+M1, J )
+ END DO
+ END DO
+ 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,
+ & A( 1, I1 ), LDA, ONE, T( I1, 1 ), LDT)
+*
+ 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,
+ & A( 1, I1 ), LDA, ONE, A( I1, I1 ), LDA )
+*
+ CALL STRMM( 'R', 'U', 'N', 'U', M2, M1 , ONE,
+ & A, LDA, T( I1, 1 ), LDT )
+*
+ DO I=1,M2
+ DO J=1,M1
+ A( I+M1, J ) = A( I+M1, J ) - T( I+M1, J )
+ T( I+M1, J )=0
+ END DO
+ END DO
+*
+* 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,
+ & T( I1, I1 ), LDT, IINFO )
+*
+* Compute T3 = T(J1:N1,1:N) = -T1 Y1^H Y2 T2
+*
+ DO I=1,M2
+ DO J=1,M1
+ T( J, I+M1 ) = (A( J, I+M1 ))
+ END DO
+ END DO
+*
+ CALL STRMM( 'R', 'U', 'T', 'U', M1, M2, ONE,
+ & A( I1, I1 ), LDA, T( 1, I1 ), LDT )
+*
+ 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,
+ & T( 1, I1 ), LDT )
+*
+ 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]
+*
+ END IF
+*
+ RETURN
+*
+* End of SGELQT3
+*
+ END
--- /dev/null
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE SGEMLQ( SIDE, TRANS, M, N, K, A, LDA, WORK1,
+* $ LWORK1, C, LDC, WORK2, LWORK2, INFO )
+*
+*
+* .. Scalar Arguments ..
+* CHARACTER SIDE, TRANS
+* INTEGER INFO, LDA, M, N, K, MB, NB, LWORK1, LWORK2, LDC
+* ..
+* .. Array Arguments ..
+* REAL A( LDA, * ), WORK1( * ), C(LDC, * ),
+* $ WORK2( * )
+*> \par Purpose:
+* =============
+*>
+*> \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
+*> factorization (DGELQ)
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] SIDE
+*> SIDE is CHARACTER*1
+*> = 'L': apply Q or Q**T from the Left;
+*> = 'R': apply Q or Q**T from the Right.
+*>
+*> \param[in] TRANS
+*> TRANS is CHARACTER*1
+*> = 'N': No transpose, apply Q;
+*> = 'T': Transpose, apply Q**T.
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows of the matrix A. M >=0.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of columns of the matrix C. N >= M.
+*> \endverbatim
+*>
+*> \param[in] K
+*> \verbatim
+*> K is INTEGER
+*> The number of elementary reflectors whose product defines
+*> the matrix Q.
+*> M >= K >= 0;
+*>
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is REAL array, dimension (LDA,K)
+*> The i-th row must contain the vector which defines the blocked
+*> elementary reflector H(i), for i = 1,2,...,k, as returned by
+*> DLASWLQ in the first k rows of its array argument A.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A.
+*> If SIDE = 'L', LDA >= max(1,M);
+*> if SIDE = 'R', LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in] WORK1
+*> \verbatim
+*> WORK1 is REAL array, dimension (MAX(1,LWORK1)) is
+*> returned by GEQR.
+*> \endverbatim
+*>
+*> \param[in] LWORK1
+*> \verbatim
+*> LWORK1 is INTEGER
+*> The dimension of the array WORK1.
+*> \endverbatim
+*>
+*> \param[in,out] C
+*> C is REAL array, dimension (LDC,N)
+*> On entry, the M-by-N matrix C.
+*> On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.
+*> \param[in] LDC
+*> LDC is INTEGER
+*> The leading dimension of the array C. LDC >= max(1,M).
+*>
+*> \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 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)),
+*> and no error message related to LWORK2 is issued by XERBLA.
+*>
+*> \endverbatim
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> < 0: if INFO = -i, the i-th argument had an illegal value
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*> 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 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
+*> 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
+*> Further Details in LASWLQ or GELQT.
+*> \endverbatim
+*>
+* =====================================================================
+ SUBROUTINE SGEMLQ( SIDE, TRANS, M, N, K, A, LDA, WORK1, LWORK1,
+ $ C, LDC, WORK2, LWORK2, INFO )
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2013
+*
+* .. Scalar Arguments ..
+ CHARACTER SIDE, TRANS
+ INTEGER INFO, LDA, M, N, K, LWORK1, LWORK2, LDC
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * ), C( LDC, * ), WORK1( * ), WORK2( * )
+* ..
+*
+* =====================================================================
+*
+* ..
+* .. Local Scalars ..
+ LOGICAL LEFT, RIGHT, TRAN, NOTRAN, LQUERY
+ INTEGER I, II, KK, MB, NB, LW, NBLCKS, MN
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* .. External Subroutines ..
+ EXTERNAL STPMLQT, SGEMLQT, XERBLA
+* .. Intrinsic Functions ..
+ INTRINSIC INT, MAX, MIN, MOD
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ LQUERY = LWORK2.LT.0
+ NOTRAN = LSAME( TRANS, 'N' )
+ TRAN = LSAME( TRANS, 'T' )
+ LEFT = LSAME( SIDE, 'L' )
+ RIGHT = LSAME( SIDE, 'R' )
+*
+ MB = INT(WORK1(4))
+ NB = INT(WORK1(5))
+ IF (LEFT) THEN
+ LW = N * MB
+ MN = M
+ ELSE
+ LW = M * MB
+ MN = N
+ END IF
+ IF ((NB.GT.K).AND.(MN.GT.K)) THEN
+ IF(MOD(MN-K, NB-K).EQ.0) THEN
+ NBLCKS = (MN-K)/(NB-K)
+ ELSE
+ NBLCKS = (MN-K)/(NB-K) + 1
+ END IF
+ ELSE
+ NBLCKS = 1
+ END IF
+*
+ INFO = 0
+ IF( .NOT.LEFT .AND. .NOT.RIGHT ) THEN
+ INFO = -1
+ ELSE IF( .NOT.TRAN .AND. .NOT.NOTRAN ) THEN
+ INFO = -2
+ ELSE IF( M.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( N.LT.0) THEN
+ INFO = -4
+ ELSE IF( K.LT.0 ) THEN
+ INFO = -5
+ ELSE IF( LDA.LT.MAX( 1, K ) ) THEN
+ INFO = -7
+ ELSE IF( LWORK1.LT.MAX( 1, MB*K*NBLCKS+5 )) THEN
+ INFO = -9
+ ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
+ INFO = -11
+ ELSE IF(( LWORK2.LT.MAX(1,LW)).AND.(.NOT.LQUERY)) THEN
+ INFO = -13
+ END IF
+*
+ IF( INFO.EQ.0) THEN
+ WORK2(1) = LW
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SGEMLQ', -INFO )
+ RETURN
+ ELSE IF (LQUERY) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( MIN(M,N,K).EQ.0 ) THEN
+ RETURN
+ 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)
+ ELSE
+ CALL SLAMSWLQ( SIDE, TRANS, M, N, K, MB, NB, A, LDA, WORK1(6),
+ $ MB, C, LDC, WORK2, LWORK2, INFO )
+ END IF
+*
+ WORK2(1) = LW
+ RETURN
+*
+* End of SGEMLQ
+*
+ END
\ No newline at end of file
--- /dev/null
+* Definition:
+* ===========
+*
+* 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:
+* =============
+*>
+*> \verbatim
+*>
+*> DGEMQRT 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 K
+*> elementary reflectors:
+*>
+*> Q = H(1) H(2) . . . H(K) = I - V T V**T
+*>
+*> 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
+*
+* Arguments:
+* ==========
+*
+*> \param[in] SIDE
+*> \verbatim
+*> SIDE is CHARACTER*1
+*> = 'L': apply Q or Q**T from the Left;
+*> = 'R': apply Q or Q**T from the Right.
+*> \endverbatim
+*>
+*> \param[in] TRANS
+*> \verbatim
+*> TRANS is CHARACTER*1
+*> = 'N': No transpose, apply Q;
+*> = 'C': Transpose, apply Q**T.
+*> \endverbatim
+*>
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows of the matrix C. M >= 0.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of columns of the matrix C. N >= 0.
+*> \endverbatim
+*>
+*> \param[in] K
+*> \verbatim
+*> K is INTEGER
+*> The number of elementary reflectors whose product defines
+*> the matrix Q.
+*> If SIDE = 'L', M >= K >= 0;
+*> if SIDE = 'R', N >= K >= 0.
+*> \endverbatim
+*>
+*> \param[in] MB
+*> \verbatim
+*> MB is INTEGER
+*> The block size used for the storage of T. K >= MB >= 1.
+*> This must be the same value of MB used to generate T
+*> in DGELQT.
+*> \endverbatim
+*>
+*> \param[in] V
+*> \verbatim
+*> V is REAL array, dimension (LDV,K)
+*> The i-th row must contain the vector which defines the
+*> elementary reflector H(i), for i = 1,2,...,k, as returned by
+*> DGELQT in the first K rows of its array argument A.
+*> \endverbatim
+*>
+*> \param[in] LDV
+*> \verbatim
+*> LDV is INTEGER
+*> The leading dimension of the array V.
+*> If SIDE = 'L', LDA >= max(1,M);
+*> if SIDE = 'R', LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in] T
+*> \verbatim
+*> T is REAL array, dimension (LDT,K)
+*> The upper triangular factors of the block reflectors
+*> as returned by DGELQT, stored as a MB-by-M matrix.
+*> \endverbatim
+*>
+*> \param[in] LDT
+*> \verbatim
+*> LDT is INTEGER
+*> The leading dimension of the array T. LDT >= MB.
+*> \endverbatim
+*>
+*> \param[in,out] C
+*> \verbatim
+*> C is REAL array, dimension (LDC,N)
+*> On entry, the M-by-N matrix C.
+*> On exit, C is overwritten by Q C, Q**T C, C Q**T or C Q.
+*> \endverbatim
+*>
+*> \param[in] LDC
+*> \verbatim
+*> LDC is INTEGER
+*> The leading dimension of the array C. LDC >= max(1,M).
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is REAL array. The dimension of
+*> WORK is N*MB if SIDE = 'L', or M*MB if SIDE = 'R'.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> < 0: if INFO = -i, the i-th argument had an illegal value
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2013
+*
+*> \ingroup doubleGEcomputational
+*
+* =====================================================================
+ SUBROUTINE SGEMLQT( SIDE, TRANS, M, N, K, MB, V, LDV, T, LDT,
+ $ C, LDC, WORK, INFO )
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2013
+*
+* .. Scalar Arguments ..
+ CHARACTER SIDE, TRANS
+ INTEGER INFO, K, LDV, LDC, M, N, MB, LDT
+* ..
+* .. Array Arguments ..
+ REAL V( LDV, * ), C( LDC, * ), T( LDT, * ), WORK( * )
+* ..
+*
+* =====================================================================
+*
+* ..
+* .. Local Scalars ..
+ LOGICAL LEFT, RIGHT, TRAN, NOTRAN
+ INTEGER I, IB, LDWORK, KF, Q
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL XERBLA, DLARFB
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* .. Test the input arguments ..
+*
+ INFO = 0
+ LEFT = LSAME( SIDE, 'L' )
+ RIGHT = LSAME( SIDE, 'R' )
+ TRAN = LSAME( TRANS, 'T' )
+ NOTRAN = LSAME( TRANS, 'N' )
+*
+ IF( LEFT ) THEN
+ LDWORK = MAX( 1, N )
+ ELSE IF ( RIGHT ) THEN
+ LDWORK = MAX( 1, M )
+ END IF
+ IF( .NOT.LEFT .AND. .NOT.RIGHT ) THEN
+ INFO = -1
+ ELSE IF( .NOT.TRAN .AND. .NOT.NOTRAN ) THEN
+ INFO = -2
+ ELSE IF( M.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( K.LT.0) THEN
+ INFO = -5
+ ELSE IF( MB.LT.1 .OR. (MB.GT.K .AND. K.GT.0)) THEN
+ INFO = -6
+ ELSE IF( LDV.LT.MAX( 1, K ) ) THEN
+ INFO = -8
+ ELSE IF( LDT.LT.MB ) THEN
+ INFO = -10
+ ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
+ INFO = -12
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SGEMLQT', -INFO )
+ RETURN
+ END IF
+*
+* .. Quick return if possible ..
+*
+ IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) RETURN
+*
+ IF( LEFT .AND. NOTRAN ) 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,
+ $ 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,
+ $ C( 1, I ), LDC, WORK, LDWORK )
+ END DO
+*
+ ELSE IF( LEFT .AND. TRAN ) THEN
+*
+ 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,
+ $ C( I, 1 ), LDC, WORK, LDWORK )
+ END DO
+*
+ ELSE IF( RIGHT .AND. NOTRAN ) THEN
+*
+ 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,
+ $ C( 1, I ), LDC, WORK, LDWORK )
+ END DO
+*
+ END IF
+*
+ RETURN
+*
+* End of SGEMLQT
+*
+ END
--- /dev/null
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE SGEMQR( SIDE, TRANS, M, N, K, A, LDA, WORK1,
+* $ LWORK1, C, LDC, WORK2, LWORK2, INFO )
+*
+*
+* .. Scalar Arguments ..
+* CHARACTER SIDE, TRANS
+* INTEGER INFO, LDA, M, N, K, LDT, LWORK1, LWORK2, LDC
+* ..
+* .. Array Arguments ..
+* REAL 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
+*> QR factorization (DGEQR)
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] SIDE
+*> SIDE is CHARACTER*1
+*> = 'L': apply Q or Q**T from the Left;
+*> = 'R': apply Q or Q**T from the Right.
+*>
+*> \param[in] TRANS
+*> TRANS is CHARACTER*1
+*> = 'N': No transpose, apply Q;
+*> = 'T': Transpose, apply Q**T.
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows of the matrix A. M >=0.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of columns of the matrix C. M >= N >= 0.
+*> \endverbatim
+*>
+*> \param[in] K
+*> \verbatim
+*> K is INTEGER
+*> The number of elementary reflectors whose product defines
+*> the matrix Q.
+*> N >= K >= 0;
+*>
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is 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
+*> its array argument A.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A.
+*> If SIDE = 'L', LDA >= max(1,M);
+*> if SIDE = 'R', LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in] WORK1
+*> \verbatim
+*> WORK1 is REAL array, dimension (MAX(1,LWORK1)) as
+*> it is returned by GEQR.
+*> \endverbatim
+*>
+*> \param[in] LWORK1
+*> \verbatim
+*> LWORK1 is INTEGER
+*> The dimension of the array WORK1.
+*> \endverbatim
+*>
+*> \param[in,out] C
+*> C is REAL array, dimension (LDC,N)
+*> On entry, the M-by-N matrix C.
+*> On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.
+*>
+*> \param[in] LDC
+*> LDC is INTEGER
+*> The leading dimension of the array C. LDC >= max(1,M).
+*>
+*> \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 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)),
+*> and no error message related to LWORK2 is issued by XERBLA.
+*>
+*> \endverbatim
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> < 0: if INFO = -i, the i-th argument had an illegal value
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*> 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 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
+*> Further Details in LATSQR or GEQRT.
+*> \endverbatim
+*>
+* =====================================================================
+ SUBROUTINE SGEMQR( SIDE, TRANS, M, N, K, A, LDA, WORK1, LWORK1,
+ $ C, LDC, WORK2, LWORK2, INFO )
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2013
+*
+* .. Scalar Arguments ..
+ CHARACTER SIDE, TRANS
+ INTEGER INFO, LDA, M, N, K, LWORK1, LWORK2, LDC
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * ), WORK1( * ), C(LDC, * ),
+ $ WORK2( * )
+* ..
+*
+* =====================================================================
+*
+* ..
+* .. Local Scalars ..
+ LOGICAL LEFT, RIGHT, TRAN, NOTRAN, LQUERY
+ INTEGER MB, NB, I, II, KK, LW, NBLCKS, MN
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* .. External Subroutines ..
+ EXTERNAL SGEMQRT, STPMQRT, XERBLA
+* .. Intrinsic Functions ..
+ INTRINSIC INT, MAX, MIN, MOD
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ LQUERY = LWORK2.LT.0
+ NOTRAN = LSAME( TRANS, 'N' )
+ TRAN = LSAME( TRANS, 'T' )
+ LEFT = LSAME( SIDE, 'L' )
+ RIGHT = LSAME( SIDE, 'R' )
+*
+ MB = INT(WORK1(4))
+ NB = INT(WORK1(5))
+ IF(LEFT) THEN
+ LW = N * NB
+ MN = M
+ ELSE IF(RIGHT) THEN
+ LW = MB * NB
+ MN = N
+ END IF
+*
+ IF ((MB.GT.K).AND.(MN.GT.K)) THEN
+ IF(MOD(MN-K, MB-K).EQ.0) THEN
+ NBLCKS = (MN-K)/(MB-K)
+ ELSE
+ NBLCKS = (MN-K)/(MB-K) + 1
+ END IF
+ ELSE
+ NBLCKS = 1
+ END IF
+*
+ INFO = 0
+ IF( .NOT.LEFT .AND. .NOT.RIGHT ) THEN
+ INFO = -1
+ ELSE IF( .NOT.TRAN .AND. .NOT.NOTRAN ) THEN
+ INFO = -2
+ ELSE IF( M.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( K.LT.0 ) THEN
+ INFO = -5
+ ELSE IF( LDA.LT.MAX( 1, K ) ) THEN
+ INFO = -7
+ ELSE IF( LWORK1.LT.MAX( 1, NB*K*NBLCKS+5 )) THEN
+ INFO = -9
+ ELSE IF( LDC.LT.MAX( 1, M ).AND.MIN(M,N,K).NE.0 ) THEN
+ INFO = -11
+ ELSE IF(( LWORK2.LT.MAX(1,LW)).AND.(.NOT.LQUERY)) THEN
+ INFO = -13
+ 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( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SGEMQR', -INFO )
+ RETURN
+ ELSE IF (LQUERY) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( MIN(M,N,K).EQ.0 ) THEN
+ RETURN
+ 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 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
+*
+ WORK2(1) = LW
+*
+ RETURN
+*
+* End of SGEMQR
+*
+ END
\ No newline at end of file
--- /dev/null
+*
+* 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:
+*> A = Q * R .
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows of the matrix A. M >= 0.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of columns of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is 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
+*> (R is upper triangular if M >= N);
+*> the elements below the diagonal represent Q (see Further Details).
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,M).
+*> \endverbatim
+*>
+*> \param[out] WORK1
+*> \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
+*> 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
+*> SLATSQR or SGEQRT
+*> \endverbatim
+*>
+*> \param[in] LWORK1
+*> \verbatim
+*> LWORK1 is INTEGER
+*> The dimension of the array WORK1.
+*> 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
+*> 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
+*> 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
+*> LWORK2 = -1.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> < 0: if INFO = -i, the i-th argument had an illegal value
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*> 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 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
+*> Further Details in LATSQR or GEQRT.
+*> \endverbatim
+*>
+* =====================================================================
+ SUBROUTINE SGEQR( M, N, A, LDA, WORK1, LWORK1, WORK2, LWORK2,
+ $ INFO)
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd. --
+* November 2013
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, M, N, LWORK1, LWORK2
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * ), WORK1( * ), WORK2( * )
+* ..
+*
+* =====================================================================
+*
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY, LMINWS
+ INTEGER MB, NB, I, II, KK, MINLW1, NBLCKS
+* ..
+* .. EXTERNAL FUNCTIONS ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* .. EXTERNAL SUBROUTINES ..
+ EXTERNAL SLATSQR, SGEQRT, XERBLA
+* .. INTRINSIC FUNCTIONS ..
+ INTRINSIC MAX, MIN, MOD
+* ..
+* .. EXTERNAL FUNCTIONS ..
+ INTEGER ILAENV
+ EXTERNAL ILAENV
+* ..
+* .. EXECUTABLE STATEMENTS ..
+*
+* TEST THE INPUT ARGUMENTS
+*
+ INFO = 0
+*
+ LQUERY = ( LWORK1.EQ.-1 .OR. LWORK2.EQ.-1 )
+*
+* 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)
+ ELSE
+ MB = M
+ NB = 1
+ END IF
+ IF( MB.GT.M.OR.MB.LE.N) MB = M
+ IF( NB.GT.MIN(M,N).OR.NB.LT.1) NB = 1
+ MINLW1 = N + 5
+ IF ((MB.GT.N).AND.(M.GT.N)) THEN
+ IF(MOD(M-N, MB-N).EQ.0) THEN
+ NBLCKS = (M-N)/(MB-N)
+ ELSE
+ NBLCKS = (M-N)/(MB-N) + 1
+ END IF
+ ELSE
+ NBLCKS = 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)
+ $ .AND.(.NOT.LQUERY)) THEN
+ IF (LWORK1.LT.MAX(1, NB * N * NBLCKS+5)) THEN
+ LMINWS = .TRUE.
+ NB = 1
+ END IF
+ IF (LWORK1.LT.MAX(1, N * NBLCKS+5)) THEN
+ LMINWS = .TRUE.
+ MB = M
+ END IF
+ IF (LWORK2.LT.NB*N) THEN
+ LMINWS = .TRUE.
+ NB = 1
+ END IF
+ END IF
+*
+ IF( M.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -4
+ 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)
+ $ .AND.(.NOT.LMINWS)) THEN
+ INFO = -8
+ END IF
+
+ IF( INFO.EQ.0) THEN
+ WORK1(1) = 1
+ WORK1(2) = NB * N * NBLCKS + 5
+ WORK1(3) = MINLW1
+ WORK1(4) = MB
+ WORK1(5) = NB
+ WORK2(1) = NB * N
+ WORK2(2) = N
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SGEQR', -INFO )
+ RETURN
+ ELSE IF (LQUERY) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( MIN(M,N).EQ.0 ) THEN
+ RETURN
+ END IF
+*
+* The QR Decomposition
+*
+ 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,
+ $ LWORK2, INFO)
+ END IF
+ RETURN
+*
+* End of SGEQR
+*
+ END
\ No newline at end of file
--- /dev/null
+* Definition:
+* ===========
+*
+* 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
+*> factorization of A. It is assumed that A has full rank.
+*>
+*>
+*>
+*> The following options are provided:
+*>
+*> 1. If TRANS = 'N' and m >= n: find the least squares solution of
+*> an overdetermined system, i.e., solve the least squares problem
+*> minimize || B - A*X ||.
+
+*> 2. If TRANS = 'N' and m < n: find the minimum norm solution of
+*> an underdetermined system A * X = B.
+
+*> 3. If TRANS = 'T' and m >= n: find the minimum norm solution of
+*> an undetermined system A**T * X = B.
+
+*> 4. If TRANS = 'T' and m < n: find the least squares solution of
+*> an overdetermined system, i.e., solve the least squares problem
+*> minimize || B - A**T * X ||.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] TRANS
+*> \verbatim
+*> TRANS is CHARACTER*1
+*> = 'N': the linear system involves A;
+*> = 'T': the linear system involves A**T.
+*> \endverbatim
+*>
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows of the matrix A. M >= 0.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of columns of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in] NRHS
+*> \verbatim
+*> NRHS is INTEGER
+*> The number of right hand sides, i.e., the number of
+*> columns of the matrices B and X. NRHS >=0.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is REAL array, dimension (LDA,N)
+*> On entry, the M-by-N matrix A.
+*> On exit,
+*> A is overwritten by details of its QR or LQ
+*> factorization as returned by DGETSQR.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,M).
+*> \endverbatim
+*>
+*> \param[in,out] B
+*> \verbatim
+*> B is REAL array, dimension (LDB,NRHS)
+*> On entry, the matrix B of right hand side vectors, stored
+*> columnwise; B is M-by-NRHS if TRANS = 'N', or N-by-NRHS
+*> if TRANS = 'T'.
+*> On exit, if INFO = 0, B is overwritten by the solution
+*> vectors, stored columnwise:
+*> if TRANS = 'N' and m >= n, rows 1 to n of B contain the least
+*> squares solution vectors.
+*> if TRANS = 'N' and m < n, rows 1 to N of B contain the
+*> minimum norm solution vectors;
+*> if TRANS = 'T' and m >= n, rows 1 to M of B contain the
+*> minimum norm solution vectors;
+*> if TRANS = 'T' and m < n, rows 1 to M of B contain the
+*> least squares solution vectors.
+*> \endverbatim
+*>
+*> \param[in] LDB
+*> \verbatim
+*> LDB is INTEGER
+*> The leading dimension of the array B. LDB >= MAX(1,M,N).
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is REAL array, dimension (MAX(1,LWORK))
+*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK,
+*> and WORK(2) returns the minimum LWORK.
+*> \endverbatim
+*>
+*> \param[in] LWORK
+*> \verbatim
+*> LWORK is INTEGER
+*> The dimension of the array WORK.
+*> IF LWORK=-1, workspace query is assumed, and
+*> WORK(1) returns the optimal LWORK,
+*> and WORK(2) returns the minimum LWORK.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> < 0: if INFO = -i, the i-th argument had an illegal value
+*> > 0: if INFO = i, the i-th diagonal element of the
+*> triangular factor of A is zero, so that A does not have
+*> full rank; the least squares solution could not be
+*> computed.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2011
+*
+*> \ingroup doubleGEsolve
+*
+* =====================================================================
+ SUBROUTINE SGETSLS( TRANS, M, N, NRHS, A, LDA, B, LDB
+ $ , WORK, LWORK, INFO )
+*
+* -- LAPACK driver routine (version 3.4.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2011
+*
+* .. Scalar Arguments ..
+ CHARACTER TRANS
+ INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS, MB
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * ), B( LDB, * ), WORK( * )
+*
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY, TRAN
+ INTEGER I, IASCL, IBSCL, J, MINMN, MAXMN, BROW, LW,
+ $ SCLLEN, MNK, WSIZEO, WSIZEM, LW1, LW2, INFO2
+ REAL ANRM, BIGNUM, BNRM, SMLNUM
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ REAL SLAMCH, SLANGE
+ EXTERNAL LSAME, ILAENV, SLABAD, SLAMCH, SLANGE
+* ..
+* .. External Subroutines ..
+ EXTERNAL SGEQR, SGEMQR, SLASCL, SLASET,
+ $ STRTRS, XERBLA, SGELQ, SGEMLQ
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC REAL, MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments.
+*
+ INFO=0
+ MINMN = MIN( M, N )
+ MAXMN = MAX( M, N )
+ MNK = MAX(MINMN,NRHS)
+ TRAN = LSAME( TRANS, 'T' )
+*
+ LQUERY = ( LWORK.EQ.-1 )
+ IF( .NOT.( LSAME( TRANS, 'N' ) .OR.
+ $ LSAME( TRANS, 'T' ) ) ) THEN
+ INFO = -1
+ ELSE IF( M.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -6
+ ELSE IF( LDB.LT.MAX( 1, M, N ) ) THEN
+ INFO = -8
+ END IF
+*
+ 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,
+ $ INFO2)
+ MB = INT(WORK(4))
+ NB = INT(WORK(5))
+ LW = INT(WORK(6))
+ CALL SGEMQR( 'L', TRANS, M, NRHS, N, A, LDA, WORK(1),
+ $ 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,
+ $ INFO2)
+ MB = INT(WORK(4))
+ NB = INT(WORK(5))
+ LW = INT(WORK(6))
+ CALL SGEMLQ( 'L', TRANS, N, NRHS, M, A, LDA, WORK(1),
+ $ 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)))
+ END IF
+*
+ IF((LWORK.LT.WSIZEO).AND.(.NOT.LQUERY)) THEN
+ INFO=-10
+ END IF
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SGETSLS', -INFO )
+ WORK( 1 ) = REAL( WSIZEO )
+ WORK( 2 ) = REAL( WSIZEM )
+ RETURN
+ ELSE IF (LQUERY) THEN
+ WORK( 1 ) = REAL( WSIZEO )
+ WORK( 2 ) = REAL( WSIZEM )
+ RETURN
+ END IF
+ IF(LWORK.LT.WSIZEO) THEN
+ LW1=INT(WORK(3))
+ LW2=MAX(LW,INT(WORK(6)))
+ ELSE
+ LW1=INT(WORK(2))
+ LW2=MAX(LW,INT(WORK(6)))
+ END IF
+*
+* Quick return if possible
+*
+ IF( MIN( M, N, NRHS ).EQ.0 ) THEN
+ CALL SLASET( 'FULL', MAX( M, N ), NRHS, ZERO, ZERO,
+ $ B, LDB )
+ RETURN
+ END IF
+*
+* Get machine parameters
+*
+ SMLNUM = SLAMCH( 'S' ) / SLAMCH( 'P' )
+ BIGNUM = ONE / SMLNUM
+ CALL SLABAD( SMLNUM, BIGNUM )
+*
+* Scale A, B if max element outside range [SMLNUM,BIGNUM]
+*
+ ANRM = SLANGE( 'M', M, N, A, LDA, RWORK )
+ IASCL = 0
+ IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
+*
+* Scale matrix norm up to SMLNUM
+*
+ CALL SLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, INFO )
+ IASCL = 1
+ ELSE IF( ANRM.GT.BIGNUM ) THEN
+*
+* Scale matrix norm down to BIGNUM
+*
+ CALL SLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, INFO )
+ IASCL = 2
+ ELSE IF( ANRM.EQ.ZERO ) THEN
+*
+* Matrix all zero. Return zero solution.
+*
+ CALL SLASET( 'F', MAXMN, NRHS, ZERO, ZERO, B, LDB )
+ GO TO 50
+ END IF
+*
+ BROW = M
+ IF ( TRAN ) THEN
+ BROW = N
+ END IF
+ BNRM = SLANGE( 'M', BROW, NRHS, B, LDB, RWORK )
+ IBSCL = 0
+ IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
+*
+* Scale matrix norm up to SMLNUM
+*
+ CALL SLASCL( 'G', 0, 0, BNRM, SMLNUM, BROW, NRHS, B, LDB,
+ $ INFO )
+ IBSCL = 1
+ ELSE IF( BNRM.GT.BIGNUM ) THEN
+*
+* Scale matrix norm down to BIGNUM
+*
+ CALL SLASCL( 'G', 0, 0, BNRM, BIGNUM, BROW, NRHS, B, LDB,
+ $ INFO )
+ IBSCL = 2
+ END IF
+*
+ IF ( M.GE.N) THEN
+*
+* compute QR factorization of A
+*
+ CALL SGEQR( M, N, A, LDA, WORK(LW2+1), LW1
+ $ , WORK(1), LW2, INFO )
+ IF (.NOT.TRAN) THEN
+*
+* Least-Squares Problem min || A * X - B ||
+*
+* B(1:M,1:NRHS) := Q**T * B(1:M,1:NRHS)
+*
+ 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 STRTRS( 'U', 'N', 'N', N, NRHS,
+ $ A, LDA, B, LDB, INFO )
+ IF(INFO.GT.0) THEN
+ RETURN
+ END IF
+ SCLLEN = N
+ ELSE
+*
+* Overdetermined system of equations A**T * X = B
+*
+* B(1:N,1:NRHS) := inv(R**T) * B(1:N,1:NRHS)
+*
+ CALL STRTRS( 'U', 'T', 'N', N, NRHS,
+ $ A, LDA, B, LDB, INFO )
+*
+ IF( INFO.GT.0 ) THEN
+ RETURN
+ END IF
+*
+* B(N+1:M,1:NRHS) = ZERO
+*
+ DO 20 J = 1, NRHS
+ DO 10 I = N + 1, M
+ B( I, J ) = ZERO
+ 10 CONTINUE
+ 20 CONTINUE
+*
+* B(1:M,1:NRHS) := Q(1:N,:) * B(1:N,1:NRHS)
+*
+ CALL SGEMQR( 'L', 'N', M, NRHS, N, A, LDA,
+ $ WORK( LW2+1), LW1, B, LDB, WORK( 1 ), LW2,
+ $ INFO )
+*
+ SCLLEN = M
+*
+ END IF
+*
+ ELSE
+*
+* Compute LQ factorization of A
+*
+ CALL SGELQ( M, N, A, LDA, WORK(LW2+1), LW1
+ $ , WORK(1), LW2, INFO )
+*
+* workspace at least M, optimally M*NB.
+*
+ IF( .NOT.TRAN ) THEN
+*
+* underdetermined system of equations A * X = B
+*
+* B(1:M,1:NRHS) := inv(L) * B(1:M,1:NRHS)
+*
+ CALL STRTRS( 'L', 'N', 'N', M, NRHS,
+ $ A, LDA, B, LDB, INFO )
+*
+ IF( INFO.GT.0 ) THEN
+ RETURN
+ END IF
+*
+* B(M+1:N,1:NRHS) = 0
+*
+ DO 40 J = 1, NRHS
+ DO 30 I = M + 1, N
+ B( I, J ) = ZERO
+ 30 CONTINUE
+ 40 CONTINUE
+*
+* B(1:N,1:NRHS) := Q(1:N,:)**T * B(1:M,1:NRHS)
+*
+ CALL SGEMLQ( 'L', 'T', N, NRHS, M, A, LDA,
+ $ WORK( LW2+1), LW1, B, LDB, WORK( 1 ), LW2,
+ $ INFO )
+*
+* workspace at least NRHS, optimally NRHS*NB
+*
+ SCLLEN = N
+*
+ ELSE
+*
+* overdetermined system min || A**T * X - B ||
+*
+* B(1:N,1:NRHS) := Q * B(1:N,1:NRHS)
+*
+ CALL SGEMLQ( 'L', 'N', N, NRHS, M, A, LDA,
+ $ WORK( LW2+1), LW1, B, LDB, WORK( 1 ), LW2,
+ $ INFO )
+*
+* workspace at least NRHS, optimally NRHS*NB
+*
+* B(1:M,1:NRHS) := inv(L**T) * B(1:M,1:NRHS)
+*
+ CALL STRTRS( 'Lower', 'Transpose', 'Non-unit', M, NRHS,
+ $ A, LDA, B, LDB, INFO )
+*
+ IF( INFO.GT.0 ) THEN
+ RETURN
+ END IF
+*
+ SCLLEN = M
+*
+ END IF
+*
+ END IF
+*
+* Undo scaling
+*
+ IF( IASCL.EQ.1 ) THEN
+ CALL SLASCL( 'G', 0, 0, ANRM, SMLNUM, SCLLEN, NRHS, B, LDB,
+ $ INFO )
+ ELSE IF( IASCL.EQ.2 ) THEN
+ CALL SLASCL( 'G', 0, 0, ANRM, BIGNUM, SCLLEN, NRHS, B, LDB,
+ $ INFO )
+ END IF
+ IF( IBSCL.EQ.1 ) THEN
+ CALL SLASCL( 'G', 0, 0, SMLNUM, BNRM, SCLLEN, NRHS, B, LDB,
+ $ INFO )
+ ELSE IF( IBSCL.EQ.2 ) THEN
+ CALL SLASCL( 'G', 0, 0, BIGNUM, BNRM, SCLLEN, NRHS, B, LDB,
+ $ INFO )
+ END IF
+*
+ 50 CONTINUE
+ WORK( 1 ) = REAL( WSIZEO )
+ WORK( 2 ) = REAL( WSIZEM )
+ RETURN
+*
+* End of SGETSLS
+*
+ END
\ No newline at end of file
--- /dev/null
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE SLAMSWLQ( SIDE, TRANS, M, N, K, MB, NB, A, LDA, T,
+* $ LDT, C, LDC, WORK, LWORK, INFO )
+*
+*
+* .. Scalar Arguments ..
+* CHARACTER SIDE, TRANS
+* INTEGER INFO, LDA, M, N, K, MB, NB, LDT, LWORK, LDC
+* ..
+* .. Array Arguments ..
+* DOUBLE A( LDA, * ), WORK( * ), C(LDC, * ),
+* $ T( LDT, * )
+*> \par Purpose:
+* =============
+*>
+*> \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
+*> factorization (DLASWLQ)
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] SIDE
+*> SIDE is CHARACTER*1
+*> = 'L': apply Q or Q**T from the Left;
+*> = 'R': apply Q or Q**T from the Right.
+*>
+*> \param[in] TRANS
+*> TRANS is CHARACTER*1
+*> = 'N': No transpose, apply Q;
+*> = 'T': Transpose, apply Q**T.
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows of the matrix A. M >=0.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of columns of the matrix C. N >= M.
+*> \endverbatim
+*>
+*> \param[in] K
+*> \verbatim
+*> K is INTEGER
+*> The number of elementary reflectors whose product defines
+*> the matrix Q.
+*> M >= K >= 0;
+*>
+*> \endverbatim
+*> \param[in] MB
+*> \verbatim
+*> MB is INTEGER
+*> 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.
+*> NB > M.
+*> \endverbatim
+*>
+*> \param[in] NB
+*> \verbatim
+*> NB is INTEGER
+*> The block size to be used in the blocked QR.
+*> MB > M.
+*>
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is REAL array, dimension (LDA,K)
+*> The i-th row must contain the vector which defines the blocked
+*> elementary reflector H(i), for i = 1,2,...,k, as returned by
+*> DLASWLQ in the first k rows of its array argument A.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A.
+*> If SIDE = 'L', LDA >= max(1,M);
+*> if SIDE = 'R', LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in] T
+*> \verbatim
+*> 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
+*> for further details.
+*> \endverbatim
+*>
+*> \param[in] LDT
+*> \verbatim
+*> LDT is INTEGER
+*> The leading dimension of the array T. LDT >= MB.
+*> \endverbatim
+*>
+*> \param[in,out] C
+*> C is REAL array, dimension (LDC,N)
+*> On entry, the M-by-N matrix C.
+*> On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.
+*> \param[in] LDC
+*> LDC is INTEGER
+*> The leading dimension of the array C. LDC >= max(1,M).
+*>
+*> \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,NB) * MB;
+*> if SIDE = 'R', LWORK >= max(1,M) * MB.
+*> If LWORK = -1, then a workspace query is assumed; the routine
+*> only calculates the optimal size of the WORK array, returns
+*> this value as the first entry of the WORK array, and no error
+*> message related to LWORK is issued by XERBLA.
+*>
+*> \endverbatim
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> < 0: if INFO = -i, the i-th argument had an illegal value
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*> Short-Wide LQ (SWLQ) performs LQ by a sequence of orthogonal transformations,
+*> representing Q as a product of other orthogonal matrices
+*> Q = Q(1) * Q(2) * . . . * Q(k)
+*> where each Q(i) zeros out upper diagonal entries of a block of NB rows of A:
+*> Q(1) zeros out the upper diagonal entries of rows 1:NB of A
+*> Q(2) zeros out the bottom MB-N rows of rows [1:M,NB+1:2*NB-M] of A
+*> Q(3) zeros out the bottom MB-N rows of rows [1:M,2*NB-M+1:3*NB-2*M] of A
+*> . . .
+*>
+*> Q(1) is computed by GELQT, which represents Q(1) by Householder vectors
+*> stored under the diagonal of rows 1:MB of A, and by upper triangular
+*> block reflectors, stored in array T(1:LDT,1:N).
+*> For more information see Further Details in GELQT.
+*>
+*> Q(i) for i>1 is computed by TPLQT, which represents Q(i) by Householder vectors
+*> stored in columns [(i-1)*(NB-M)+M+1:i*(NB-M)+M] of A, and by upper triangular
+*> 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].
+*>
+*> [1] “Communication-Optimal Parallel and Sequential QR and LU Factorizations,”
+*> J. Demmel, L. Grigori, M. Hoemmen, J. Langou,
+*> SIAM J. Sci. Comput, vol. 34, no. 1, 2012
+*> \endverbatim
+*>
+* =====================================================================
+ 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) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2013
+*
+* .. Scalar Arguments ..
+ CHARACTER SIDE, TRANS
+ INTEGER INFO, LDA, M, N, K, MB, NB, LDT, LWORK, LDC
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * ), WORK( * ), C(LDC, * ),
+ $ T( LDT, * )
+* ..
+*
+* =====================================================================
+*
+* ..
+* .. Local Scalars ..
+ LOGICAL LEFT, RIGHT, TRAN, NOTRAN, LQUERY
+ INTEGER I, II, KK, LW, CTR
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* .. External Subroutines ..
+ EXTERNAL STPMLQT, SGEMLQT, XERBLA
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ LQUERY = LWORK.LT.0
+ NOTRAN = LSAME( TRANS, 'N' )
+ TRAN = LSAME( TRANS, 'T' )
+ LEFT = LSAME( SIDE, 'L' )
+ RIGHT = LSAME( SIDE, 'R' )
+ IF (LEFT) THEN
+ LW = N * MB
+ ELSE
+ LW = M * MB
+ END IF
+*
+ INFO = 0
+ IF( .NOT.LEFT .AND. .NOT.RIGHT ) THEN
+ INFO = -1
+ ELSE IF( .NOT.TRAN .AND. .NOT.NOTRAN ) THEN
+ INFO = -2
+ ELSE IF( M.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( K.LT.0 ) THEN
+ INFO = -5
+ ELSE IF( LDA.LT.MAX( 1, K ) ) THEN
+ INFO = -9
+ ELSE IF( LDT.LT.MAX( 1, MB) ) THEN
+ INFO = -11
+ ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
+ INFO = -13
+ ELSE IF(( LWORK.LT.MAX(1,LW)).AND.(.NOT.LQUERY)) THEN
+ INFO = -15
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SLAMSWLQ', -INFO )
+ WORK(1) = LW
+ RETURN
+ ELSE IF (LQUERY) THEN
+ WORK(1) = LW
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( MIN(M,N,K).EQ.0 ) THEN
+ RETURN
+ 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)
+ RETURN
+ END IF
+*
+ IF(LEFT.AND.TRAN) THEN
+*
+* Multiply Q to the last block of C
+*
+ KK = MOD((M-K),(NB-K))
+ CTR = (M-K)/(NB-K)
+*
+ IF (KK.GT.0) THEN
+ II=M-KK+1
+ CALL STPMLQT('L','T',KK , N, K, 0, MB, A(1,II), LDA,
+ $ T(1,CTR*K+1), LDT, C(1,1), LDC,
+ $ C(II,1), LDC, WORK, INFO )
+ ELSE
+ II=M+1
+ END IF
+*
+ DO I=II-(NB-K),NB+1,-(NB-K)
+*
+* Multiply Q to the current block of C (1:M,I:I+NB)
+*
+ CTR = CTR - 1
+ CALL STPMLQT('L','T',NB-K , N, K, 0,MB, A(1,I), 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:M,1:NB)
+*
+ CALL SGEMLQT('L','T',NB , N, K, MB, A(1,1), LDA, T
+ $ ,LDT ,C(1,1), LDC, WORK, INFO )
+*
+ ELSE IF (LEFT.AND.NOTRAN) THEN
+*
+* Multiply Q to the first block of C
+*
+ KK = MOD((M-K),(NB-K))
+ II=M-KK+1
+ CTR = 1
+ CALL SGEMLQT('L','N',NB , N, K, MB, A(1,1), LDA, T
+ $ ,LDT ,C(1,1), LDC, WORK, INFO )
+*
+ DO I=NB+1,II-NB+K,(NB-K)
+*
+* Multiply Q to the current block of C (I:I+NB,1:N)
+*
+ CALL STPMLQT('L','N',NB-K , N, K, 0,MB, A(1,I), LDA,
+ $ T(1,CTR * K+1), LDT, C(1,1), LDC,
+ $ C(I,1), LDC, WORK, INFO )
+ CTR = CTR + 1
+*
+ END DO
+ IF(II.LE.M) THEN
+*
+* Multiply Q to the last block of C
+*
+ CALL STPMLQT('L','N',KK , N, K, 0, MB, A(1,II), LDA,
+ $ T(1,CTR*K+1), LDT, C(1,1), LDC,
+ $ C(II,1), LDC, WORK, INFO )
+*
+ END IF
+*
+ ELSE IF(RIGHT.AND.NOTRAN) THEN
+*
+* Multiply Q to the last block of C
+*
+ KK = MOD((N-K),(NB-K))
+ CTR = (N-K)/(NB-K)
+ IF (KK.GT.0) THEN
+ II=N-KK+1
+ CALL STPMLQT('R','N',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 )
+ ELSE
+ II=N+1
+ END IF
+*
+ DO I=II-(NB-K),NB+1,-(NB-K)
+*
+* Multiply Q to the current block of C (1:M,I:I+MB)
+*
+ CTR = CTR - 1
+ CALL STPMLQT('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 )
+
+ END DO
+*
+* Multiply Q to the first block of C (1:M,1:MB)
+*
+ CALL SGEMLQT('R','N',M , NB, K, MB, A(1,1), LDA, T
+ $ ,LDT ,C(1,1), LDC, WORK, INFO )
+*
+ ELSE IF (RIGHT.AND.TRAN) THEN
+*
+* Multiply Q to the first block of C
+*
+ KK = MOD((N-K),(NB-K))
+ II=N-KK+1
+ CTR = 1
+ CALL SGEMLQT('R','T',M , NB, K, MB, A(1,1), LDA, T
+ $ ,LDT ,C(1,1), LDC, WORK, INFO )
+*
+ DO I=NB+1,II-NB+K,(NB-K)
+*
+* Multiply Q to the current block of C (1:M,I:I+MB)
+*
+ CALL STPMLQT('R','T',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 )
+ CTR = CTR + 1
+*
+ END DO
+ 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 IF
+*
+ END IF
+*
+ WORK(1) = LW
+ RETURN
+*
+* End of SLAMSWLQ
+*
+ END
\ No newline at end of file
--- /dev/null
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE SLAMTSQR( SIDE, TRANS, M, N, K, MB, NB, A, LDA, T,
+* $ LDT, C, LDC, WORK, LWORK, INFO )
+*
+*
+* .. Scalar Arguments ..
+* CHARACTER SIDE, TRANS
+* INTEGER INFO, LDA, M, N, K, MB, NB, LDT, LWORK, LDC
+* ..
+* .. Array Arguments ..
+* DOUBLE A( LDA, * ), WORK( * ), C(LDC, * ),
+* $ T( LDT, * )
+*> \par Purpose:
+* =============
+*>
+*> \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
+*> QR factorization (DLATSQR)
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] SIDE
+*> SIDE is CHARACTER*1
+*> = 'L': apply Q or Q**T from the Left;
+*> = 'R': apply Q or Q**T from the Right.
+*>
+*> \param[in] TRANS
+*> TRANS is CHARACTER*1
+*> = 'N': No transpose, apply Q;
+*> = 'T': Transpose, apply Q**T.
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows of the matrix A. M >=0.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of columns of the matrix C. M >= N >= 0.
+*> \endverbatim
+*>
+*> \param[in] K
+*> \verbatim
+*> K is INTEGER
+*> The number of elementary reflectors whose product defines
+*> the matrix Q.
+*> N >= K >= 0;
+*>
+*> \endverbatim
+*>
+*> \param[in] MB
+*> \verbatim
+*> MB is INTEGER
+*> 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.
+*> 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
+*> its array argument A.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A.
+*> If SIDE = 'L', LDA >= max(1,M);
+*> if SIDE = 'R', LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in] T
+*> \verbatim
+*> 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
+*> for further details.
+*> \endverbatim
+*>
+*> \param[in] LDT
+*> \verbatim
+*> LDT is INTEGER
+*> The leading dimension of the array T. LDT >= NB.
+*> \endverbatim
+*>
+*> \param[in,out] C
+*> C is REAL array, dimension (LDC,N)
+*> On entry, the M-by-N matrix C.
+*> On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.
+*> \param[in] LDC
+*> LDC is INTEGER
+*> The leading dimension of the array C. LDC >= max(1,M).
+*>
+*> \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
+*> only calculates the optimal size of the WORK array, returns
+*> this value as the first entry of the WORK array, and no error
+*> message related to LWORK is issued by XERBLA.
+*>
+*> \endverbatim
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> < 0: if INFO = -i, the i-th argument had an illegal value
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*> Tall-Skinny QR (TSQR) performs QR by a sequence of orthogonal transformations,
+*> representing Q as a product of other orthogonal matrices
+*> Q = Q(1) * Q(2) * . . . * Q(k)
+*> where each Q(i) zeros out subdiagonal entries of a block of MB rows of A:
+*> Q(1) zeros out the subdiagonal entries of rows 1:MB of A
+*> Q(2) zeros out the bottom MB-N rows of rows [1:N,MB+1:2*MB-N] of A
+*> Q(3) zeros out the bottom MB-N rows of rows [1:N,2*MB-N+1:3*MB-2*N] of A
+*> . . .
+*>
+*> Q(1) is computed by GEQRT, which represents Q(1) by Householder vectors
+*> stored under the diagonal of rows 1:MB of A, and by upper triangular
+*> block reflectors, stored in array T(1:LDT,1:N).
+*> For more information see Further Details in GEQRT.
+*>
+*> Q(i) for i>1 is computed by TPQRT, which represents Q(i) by Householder vectors
+*> stored in rows [(i-1)*(MB-N)+N+1:i*(MB-N)+N] of A, and by upper triangular
+*> 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].
+*>
+*> [1] “Communication-Optimal Parallel and Sequential QR and LU Factorizations,”
+*> J. Demmel, L. Grigori, M. Hoemmen, J. Langou,
+*> SIAM J. Sci. Comput, vol. 34, no. 1, 2012
+*> \endverbatim
+*>
+* =====================================================================
+ 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) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2013
+*
+* .. Scalar Arguments ..
+ CHARACTER SIDE, TRANS
+ INTEGER INFO, LDA, M, N, K, MB, NB, LDT, LWORK, LDC
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * ), WORK( * ), C(LDC, * ),
+ $ T( LDT, * )
+* ..
+*
+* =====================================================================
+*
+* ..
+* .. Local Scalars ..
+ LOGICAL LEFT, RIGHT, TRAN, NOTRAN, LQUERY
+ INTEGER I, II, KK, LW, CTR
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* .. External Subroutines ..
+ EXTERNAL SGEMQRT, STPMQRT, XERBLA
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ LQUERY = LWORK.LT.0
+ NOTRAN = LSAME( TRANS, 'N' )
+ TRAN = LSAME( TRANS, 'T' )
+ LEFT = LSAME( SIDE, 'L' )
+ RIGHT = LSAME( SIDE, 'R' )
+ IF (LEFT) THEN
+ LW = N * NB
+ ELSE
+ LW = MB * NB
+ END IF
+*
+ INFO = 0
+ IF( .NOT.LEFT .AND. .NOT.RIGHT ) THEN
+ INFO = -1
+ ELSE IF( .NOT.TRAN .AND. .NOT.NOTRAN ) THEN
+ INFO = -2
+ ELSE IF( M.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( K.LT.0 ) THEN
+ INFO = -5
+ ELSE IF( LDA.LT.MAX( 1, K ) ) THEN
+ INFO = -9
+ ELSE IF( LDT.LT.MAX( 1, NB) ) THEN
+ INFO = -11
+ ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
+ INFO = -13
+ ELSE IF(( LWORK.LT.MAX(1,LW)).AND.(.NOT.LQUERY)) THEN
+ INFO = -15
+ END IF
+ 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( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SLAMTSQR', -INFO )
+ RETURN
+ ELSE IF (LQUERY) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( MIN(M,N,K).EQ.0 ) THEN
+ RETURN
+ 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)
+ RETURN
+ END IF
+*
+ IF(LEFT.AND.NOTRAN) THEN
+*
+* Multiply Q to the last block of C
+*
+ KK = MOD((M-K),(MB-K))
+ CTR = (M-K)/(MB-K)
+ IF (KK.GT.0) THEN
+ II=M-KK+1
+ CALL STPMQRT('L','N',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 )
+ ELSE
+ II=M+1
+ END IF
+*
+ DO I=II-(MB-K),MB+1,-(MB-K)
+*
+* Multiply Q to the current block of C (I:I+MB,1:N)
+*
+ CTR = CTR - 1
+ 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)
+*
+ CALL SGEMQRT('L','N',MB , N, K, NB, A(1,1), LDA, T
+ $ ,LDT ,C(1,1), LDC, WORK, INFO )
+*
+ ELSE IF (LEFT.AND.TRAN) THEN
+*
+* Multiply Q to the first block of C
+*
+ KK = MOD((M-K),(MB-K))
+ II=M-KK+1
+ CTR = 1
+ CALL SGEMQRT('L','T',MB , N, K, NB, A(1,1), LDA, T
+ $ ,LDT ,C(1,1), LDC, WORK, INFO )
+*
+ DO I=MB+1,II-MB+K,(MB-K)
+*
+* Multiply Q to the current block of C (I:I+MB,1:N)
+*
+ CALL STPMQRT('L','T',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 )
+ CTR = CTR + 1
+*
+ END DO
+ 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
+*
+ ELSE IF(RIGHT.AND.TRAN) THEN
+*
+* Multiply Q to the last block of C
+*
+ KK = MOD((N-K),(MB-K))
+ CTR = (N-K)/(MB-K)
+ IF (KK.GT.0) THEN
+ II=N-KK+1
+ CALL STPMQRT('R','T',M , KK, K, 0, NB, A(II,1), LDA,
+ $ T(1, CTR * K + 1), LDT, C(1,1), LDC,
+ $ C(1,II), LDC, WORK, INFO )
+ ELSE
+ II=N+1
+ END IF
+*
+ DO I=II-(MB-K),MB+1,-(MB-K)
+*
+* Multiply Q to the current block of C (1:M,I:I+MB)
+*
+ CTR = CTR - 1
+ CALL STPMQRT('R','T',M , MB-K, K, 0,NB, A(I,1), LDA,
+ $ T(1, CTR * K + 1), LDT, C(1,1), LDC,
+ $ C(1,I), LDC, WORK, INFO )
+ END DO
+*
+* Multiply Q to the first block of C (1:M,1:MB)
+*
+ CALL SGEMQRT('R','T',M , MB, K, NB, A(1,1), LDA, T
+ $ ,LDT ,C(1,1), LDC, WORK, INFO )
+*
+ ELSE IF (RIGHT.AND.NOTRAN) THEN
+*
+* Multiply Q to the first block of C
+*
+ KK = MOD((N-K),(MB-K))
+ II=N-KK+1
+ CTR = 1
+ CALL SGEMQRT('R','N', M, MB , K, NB, A(1,1), LDA, T
+ $ ,LDT ,C(1,1), LDC, WORK, INFO )
+*
+ DO I=MB+1,II-MB+K,(MB-K)
+*
+* Multiply Q to the current block of C (1:M,I:I+MB)
+*
+ CALL STPMQRT('R','N', M, MB-K, K, 0,NB, A(I,1), LDA,
+ $ T(1, CTR * K + 1),LDT, C(1,1), LDC,
+ $ C(1,I), LDC, WORK, INFO )
+ CTR = CTR + 1
+*
+ END DO
+ IF(II.LE.N) THEN
+*
+* Multiply Q to the last block of C
+*
+ CALL STPMQRT('R','N', M, KK , K, 0,NB, A(II,1), LDA,
+ $ T(1, CTR * K + 1),LDT, C(1,1), LDC,
+ $ C(1,II), LDC, WORK, INFO )
+*
+ END IF
+*
+ END IF
+*
+ WORK(1) = LW
+ RETURN
+*
+* End of SLAMTSQR
+*
+ END
\ No newline at end of file
--- /dev/null
+*
+* 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
+*> M-by-N matrix A, where N >= M:
+*> A = L * Q
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows of the matrix A. M >= 0.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of columns of the matrix A. N >= M >= 0.
+*> \endverbatim
+*>
+*> \param[in] MB
+*> \verbatim
+*> MB is INTEGER
+*> 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.
+*> NB > M.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \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
+*> of blocked V (see Further Details).
+*>
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,M).
+*> \endverbatim
+*>
+*> \param[out] T
+*> \verbatim
+*> 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.
+*> See Further Details below.
+*> \endverbatim
+*>
+*> \param[in] LDT
+*> \verbatim
+*> LDT is INTEGER
+*> The leading dimension of the array T. LDT >= MB.
+*> \endverbatim
+*>
+*>
+*> \param[out] WORK
+*> \verbatim
+*> (workspace) REAL array, dimension (MAX(1,LWORK))
+*>
+*> \endverbatim
+*> \param[in] LWORK
+*> \verbatim
+*> The dimension of the array WORK. LWORK >= MB * M.
+*> If LWORK = -1, then a workspace query is assumed; the routine
+*> only calculates the optimal size of the WORK array, returns
+*> this value as the first entry of the WORK array, and no error
+*> message related to LWORK is issued by XERBLA.
+*>
+*> \endverbatim
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> < 0: if INFO = -i, the i-th argument had an illegal value
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*> Short-Wide LQ (SWLQ) performs LQ by a sequence of orthogonal transformations,
+*> representing Q as a product of other orthogonal matrices
+*> Q = Q(1) * Q(2) * . . . * Q(k)
+*> where each Q(i) zeros out upper diagonal entries of a block of NB rows of A:
+*> Q(1) zeros out the upper diagonal entries of rows 1:NB of A
+*> Q(2) zeros out the bottom MB-N rows of rows [1:M,NB+1:2*NB-M] of A
+*> Q(3) zeros out the bottom MB-N rows of rows [1:M,2*NB-M+1:3*NB-2*M] of A
+*> . . .
+*>
+*> Q(1) is computed by GELQT, which represents Q(1) by Householder vectors
+*> stored under the diagonal of rows 1:MB of A, and by upper triangular
+*> block reflectors, stored in array T(1:LDT,1:N).
+*> For more information see Further Details in GELQT.
+*>
+*> Q(i) for i>1 is computed by TPLQT, which represents Q(i) by Householder vectors
+*> stored in columns [(i-1)*(NB-M)+M+1:i*(NB-M)+M] of A, and by upper triangular
+*> 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].
+*>
+*> [1] “Communication-Optimal Parallel and Sequential QR and LU Factorizations,”
+*> J. Demmel, L. Grigori, M. Hoemmen, J. Langou,
+*> SIAM J. Sci. Comput, vol. 34, no. 1, 2012
+*> \endverbatim
+*>
+* =====================================================================
+ SUBROUTINE SLASWLQ( M, N, MB, NB, A, LDA, T, LDT, WORK, LWORK,
+ $ INFO)
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd. --
+* November 2013
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, M, N, MB, NB, LWORK, LDT
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * ), WORK( * ), T( LDT, *)
+* ..
+*
+* =====================================================================
+*
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY
+ INTEGER I, II, KK, CTR
+* ..
+* .. EXTERNAL FUNCTIONS ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* .. EXTERNAL SUBROUTINES ..
+ EXTERNAL SGEQRT, STPQRT, XERBLA
+* .. INTRINSIC FUNCTIONS ..
+ INTRINSIC MAX, MIN, MOD
+* ..
+* .. EXECUTABLE STATEMENTS ..
+*
+* TEST THE INPUT ARGUMENTS
+*
+ INFO = 0
+*
+ LQUERY = ( LWORK.EQ.-1 )
+*
+ IF( M.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 .OR. N.LT.M ) THEN
+ INFO = -2
+ ELSE IF( MB.LT.1 .OR. ( MB.GT.M .AND. M.GT.0 )) THEN
+ INFO = -3
+ ELSE IF( NB.LE.M ) THEN
+ INFO = -4
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -5
+ 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
+ WORK(1) = MB*M
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SLASWLQ', -INFO )
+ RETURN
+ ELSE IF (LQUERY) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( MIN(M,N).EQ.0 ) THEN
+ RETURN
+ END IF
+*
+* The LQ Decomposition
+*
+ 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
+*
+ KK = MOD((N-M),(NB-M))
+ II=N-KK+1
+*
+* Compute the LQ factorization of the first block A(1:M,1:NB)
+*
+ CALL SGELQT( M, NB, MB, A(1,1), LDA, T, LDT, WORK, INFO)
+ 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 ),
+ $ LDA, T(1, CTR * M + 1),
+ $ LDT, WORK, INFO )
+ CTR = CTR + 1
+ END DO
+*
+* Compute the QR factorization of the last block A(1:M,II:N)
+*
+ IF (II.LE.N) THEN
+ CALL STPLQT( M, KK, 0, MB, A(1,1), LDA, A( 1, II ),
+ $ LDA, T(1, CTR * M + 1), LDT,
+ $ WORK, INFO )
+ END IF
+*
+ WORK( 1 ) = M * MB
+ RETURN
+*
+* End of SLASWLQ
+*
+ END
\ No newline at end of file
--- /dev/null
+*
+* Definition:
+* ===========
+*
+* 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
+*> an M-by-N matrix A, where M >= N:
+*> A = Q * R .
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows of the matrix A. M >= 0.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of columns of the matrix A. M >= N >= 0.
+*> \endverbatim
+*>
+*> \param[in] MB
+*> \verbatim
+*> MB is INTEGER
+*> 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.
+*> N >= NB >= 1.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \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
+*> of blocked V (see Further Details).
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,M).
+*> \endverbatim
+*>
+*> \param[out] T
+*> \verbatim
+*> 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.
+*> See Further Details below.
+*> \endverbatim
+*>
+*> \param[in] LDT
+*> \verbatim
+*> LDT is INTEGER
+*> The leading dimension of the array T. LDT >= NB.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> (workspace) REAL array, dimension (MAX(1,LWORK))
+*> \endverbatim
+*>
+*> \param[in] LWORK
+*> \verbatim
+*> The dimension of the array WORK. LWORK >= NB*N.
+*> If LWORK = -1, then a workspace query is assumed; the routine
+*> only calculates the optimal size of the WORK array, returns
+*> this value as the first entry of the WORK array, and no error
+*> message related to LWORK is issued by XERBLA.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> < 0: if INFO = -i, the i-th argument had an illegal value
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*> Tall-Skinny QR (TSQR) performs QR by a sequence of orthogonal transformations,
+*> representing Q as a product of other orthogonal matrices
+*> Q = Q(1) * Q(2) * . . . * Q(k)
+*> where each Q(i) zeros out subdiagonal entries of a block of MB rows of A:
+*> Q(1) zeros out the subdiagonal entries of rows 1:MB of A
+*> Q(2) zeros out the bottom MB-N rows of rows [1:N,MB+1:2*MB-N] of A
+*> Q(3) zeros out the bottom MB-N rows of rows [1:N,2*MB-N+1:3*MB-2*N] of A
+*> . . .
+*>
+*> Q(1) is computed by GEQRT, which represents Q(1) by Householder vectors
+*> stored under the diagonal of rows 1:MB of A, and by upper triangular
+*> block reflectors, stored in array T(1:LDT,1:N).
+*> For more information see Further Details in GEQRT.
+*>
+*> Q(i) for i>1 is computed by TPQRT, which represents Q(i) by Householder vectors
+*> stored in rows [(i-1)*(MB-N)+N+1:i*(MB-N)+N] of A, and by upper triangular
+*> 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].
+*>
+*> [1] “Communication-Optimal Parallel and Sequential QR and LU Factorizations,”
+*> J. Demmel, L. Grigori, M. Hoemmen, J. Langou,
+*> SIAM J. Sci. Comput, vol. 34, no. 1, 2012
+*> \endverbatim
+*>
+* =====================================================================
+ SUBROUTINE SLATSQR( M, N, MB, NB, A, LDA, T, LDT, WORK,
+ $ LWORK, INFO)
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd. --
+* November 2013
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, M, N, MB, NB, LDT, LWORK
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * ), WORK( * ), T(LDT, *)
+* ..
+*
+* =====================================================================
+*
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY
+ INTEGER I, II, KK, CTR
+* ..
+* .. EXTERNAL FUNCTIONS ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* .. EXTERNAL SUBROUTINES ..
+ EXTERNAL SGEQRT, STPQRT, XERBLA
+* .. INTRINSIC FUNCTIONS ..
+ INTRINSIC MAX, MIN, MOD
+* ..
+* .. EXECUTABLE STATEMENTS ..
+*
+* TEST THE INPUT ARGUMENTS
+*
+ INFO = 0
+*
+ LQUERY = ( LWORK.EQ.-1 )
+*
+ IF( M.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 .OR. M.LT.N ) THEN
+ INFO = -2
+ ELSE IF( MB.LE.N ) THEN
+ 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
+ INFO = -5
+ ELSE IF( LDT.LT.NB ) THEN
+ INFO = -8
+ ELSE IF( LWORK.LT.(N*NB) .AND. (.NOT.LQUERY) ) THEN
+ INFO = -10
+ END IF
+ IF( INFO.EQ.0) THEN
+ WORK(1) = NB*N
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SLATSQR', -INFO )
+ RETURN
+ ELSE IF (LQUERY) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( MIN(M,N).EQ.0 ) THEN
+ RETURN
+ END IF
+*
+* The QR Decomposition
+*
+ IF ((MB.LE.N).OR.(MB.GE.M)) THEN
+ CALL SGEQRT( M, N, NB, A, LDA, T, LDT, WORK, INFO)
+ RETURN
+ END IF
+ KK = MOD((M-N),(MB-N))
+ II=M-KK+1
+*
+* Compute the QR factorization of the first block A(1:MB,1:N)
+*
+ CALL SGEQRT( MB, N, NB, A(1,1), LDA, T, LDT, WORK, INFO )
+*
+ 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,
+ $ T(1, CTR * N + 1),
+ $ LDT, WORK, INFO )
+ CTR = CTR + 1
+ END DO
+*
+* Compute the QR factorization of the last block A(II:M,1:N)
+*
+ IF (II.LE.M) THEN
+ CALL STPQRT( KK, N, 0, NB, A(1,1), LDA, A( II, 1 ), LDA,
+ $ T(1, CTR * N + 1), LDT,
+ $ WORK, INFO )
+ END IF
+*
+ work( 1 ) = N*NB
+ RETURN
+*
+* End of SLATSQR
+*
+ END
\ No newline at end of file
--- /dev/null
+*> \brief \b STPLQT
+*
+* =========== DOCUMENTATION ===========
+*
+* 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">
+*> [TXT]</a>
+*> \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
+*> WY representation for Q.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows of the matrix B, and the order of the
+*> triangular matrix A.
+*> M >= 0.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of columns of the matrix B.
+*> N >= 0.
+*> \endverbatim
+*>
+*> \param[in] L
+*> \verbatim
+*> L is INTEGER
+*> The number of rows of the lower trapezoidal part of B.
+*> MIN(M,N) >= L >= 0. See Further Details.
+*> \endverbatim
+*>
+*> \param[in] MB
+*> \verbatim
+*> MB is INTEGER
+*> The block size to be used in the blocked QR. M >= MB >= 1.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is REAL array, dimension (LDA,N)
+*> On entry, the lower triangular N-by-N matrix A.
+*> On exit, the elements on and below the diagonal of the array
+*> contain the lower triangular matrix L.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in,out] B
+*> \verbatim
+*> B is REAL array, dimension (LDB,N)
+*> 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
+*>
+*> \param[in] LDB
+*> \verbatim
+*> LDB is INTEGER
+*> The leading dimension of the array B. LDB >= max(1,M).
+*> \endverbatim
+*>
+*> \param[out] T
+*> \verbatim
+*> T is REAL array, dimension (LDT,N)
+*> 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
+*> The leading dimension of the array T. LDT >= MB.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is REAL array, dimension (MB*M)
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> < 0: if INFO = -i, the i-th argument had an illegal value
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2013
+*
+*> \ingroup doubleOTHERcomputational
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*>
+*> 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 ]
+*> [ 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.
+*>
+*> 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 ]
+*> [ A ] <- lower triangular N-by-N
+*> [ B ] <- M-by-N pentagonal
+*>
+*> so that W can be represented as
+*> [ 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 ]
+*> [ 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 number of blocks is B = ceiling(M/MB), where each
+*> 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
+*> for the last block) T's are stored in the MB-by-N matrix T as
+*>
+*> T = [T1 T2 ... TB].
+*> \endverbatim
+*>
+* =====================================================================
+ SUBROUTINE STPLQT( M, N, L, MB, A, LDA, B, LDB, T, LDT, WORK,
+ $ INFO )
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2013
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, LDB, LDT, N, M, L, MB
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * ), B( LDB, * ), T( LDT, * ), WORK( * )
+* ..
+*
+* =====================================================================
+*
+* ..
+* .. Local Scalars ..
+ INTEGER I, IB, LB, NB, IINFO
+* ..
+* .. External Subroutines ..
+ EXTERNAL STPLQT2, STPRFB, XERBLA
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+ IF( M.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( L.LT.0 .OR. (L.GT.MIN(M,N) .AND. MIN(M,N).GE.0)) THEN
+ INFO = -3
+ ELSE IF( MB.LT.1 .OR. (MB.GT.M .AND. M.GT.0)) THEN
+ INFO = -4
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -6
+ ELSE IF( LDB.LT.MAX( 1, M ) ) THEN
+ INFO = -8
+ ELSE IF( LDT.LT.MB ) THEN
+ INFO = -10
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'STPLQT', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ 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 )
+ NB = MIN( N-L+I+IB-1, N )
+ IF( I.GE.L ) THEN
+ LB = 0
+ ELSE
+ LB = NB-N+L-I+1
+ END IF
+*
+ 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,
+ $ WORK, M-I-IB+1)
+ END IF
+ END DO
+ RETURN
+*
+* End of STPLQT
+*
+ END
--- /dev/null
+*> \brief \b STPLQT2 computes a LQ factorization of a real or complex "triangular-pentagonal" matrix, which is composed of a triangular block and a pentagonal block, using the compact WY representation for Q.
+*
+* =========== DOCUMENTATION ===========
+*
+* 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">
+*> [TXT]</a>
+*> \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,
+*> using the compact WY representation for Q.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The total number of rows of the matrix B.
+*> M >= 0.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of columns of the matrix B, and the order of
+*> the triangular matrix A.
+*> N >= 0.
+*> \endverbatim
+*>
+*> \param[in] L
+*> \verbatim
+*> L is INTEGER
+*> The number of rows of the lower trapezoidal part of B.
+*> MIN(M,N) >= L >= 0. See Further Details.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is REAL array, dimension (LDA,N)
+*> On entry, the lower triangular M-by-M matrix A.
+*> On exit, the elements on and below the diagonal of the array
+*> contain the lower triangular matrix L.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in,out] B
+*> \verbatim
+*> B is REAL array, dimension (LDB,N)
+*> 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
+*>
+*> \param[in] LDB
+*> \verbatim
+*> LDB is INTEGER
+*> The leading dimension of the array B. LDB >= max(1,M).
+*> \endverbatim
+*>
+*> \param[out] T
+*> \verbatim
+*> T is REAL array, dimension (LDT,M)
+*> The N-by-N upper triangular factor T of the block reflector.
+*> See Further Details.
+*> \endverbatim
+*>
+*> \param[in] LDT
+*> \verbatim
+*> LDT is INTEGER
+*> The leading dimension of the array T. LDT >= max(1,M)
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> < 0: if INFO = -i, the i-th argument had an illegal value
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date September 2012
+*
+*> \ingroup doubleOTHERcomputational
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*>
+*> 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
+*> upper trapezoidal matrix B2:
+*>
+*> B = [ B1 ][ B2 ]
+*> [ B1 ] <- M-by-(N-L) rectangular
+*> [ 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.
+*>
+*> 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 ]
+*> [ A ] <- lower triangular N-by-N
+*> [ B ] <- M-by-N pentagonal
+*>
+*> so that W can be represented as
+*>
+*> 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,
+*>
+*> 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 (M+N)-by-(M+N) block reflector H is then given by
+*>
+*> H = I - W**T * T * W
+*>
+*> where W^H is the conjugate transpose of W and T is the upper triangular
+*> factor of the block reflector.
+*> \endverbatim
+*>
+* =====================================================================
+ SUBROUTINE STPLQT2( M, N, L, A, LDA, B, LDB, T, LDT, INFO )
+*
+* -- LAPACK computational routine (version 3.4.2) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* September 2012
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, LDB, LDT, N, M, L
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * ), B( LDB, * ), T( LDT, * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE, ZERO
+ PARAMETER( ONE = 1.0, ZERO = 0.0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, J, P, MP, NP
+ REAL ALPHA
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLARFG, SGEMV, SGER, STRMV, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+ IF( M.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( L.LT.0 .OR. L.GT.MIN(M,N) ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -5
+ ELSE IF( LDB.LT.MAX( 1, M ) ) THEN
+ INFO = -7
+ ELSE IF( LDT.LT.MAX( 1, M ) ) THEN
+ INFO = -9
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'STPLQT2', -INFO )
+ RETURN
+ END IF
+*
+* 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,:)
+*
+ P = N-L+MIN( L, I )
+ CALL SLARFG( P+1, A( I, I ), B( I, 1 ), LDB, T( 1, I ) )
+ IF( I.LT.M ) THEN
+*
+* W(M-I:1) := C(I+1:M,I:N) * C(I,I:N) [use W = T(M,:)]
+*
+ 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,
+ $ 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 ))
+ DO J = 1, M-I
+ A( I+J, I ) = A( I+J, I ) + ALPHA*(T( M, J ))
+ END DO
+ CALL SGER( M-I, P, ALPHA, T( M, 1 ), LDT,
+ $ B( I, 1 ), LDB, B( I+1, 1 ), LDB )
+ END IF
+ END DO
+*
+ DO I = 2, M
+*
+* T(I,1:I-1) := C(I:I-1,1:N) * (alpha * C(I,I:N)^H)
+*
+ ALPHA = -T( 1, I )
+
+ DO J = 1, I-1
+ T( I, J ) = ZERO
+ END DO
+ P = MIN( I-1, L )
+ NP = MIN( N-L+1, N )
+ MP = MIN( P+1, M )
+*
+* Triangular part of B2
+*
+ DO J = 1, P
+ T( I, J ) = ALPHA*B( I, N-L+J )
+ END DO
+ CALL STRMV( 'L', 'N', 'N', P, B( 1, NP ), LDB,
+ $ T( I, 1 ), LDT )
+*
+* Rectangular part of B2
+*
+ 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 )
+*
+* T(1:I-1,I) := T(1:I-1,1:I-1) * T(I,1:I-1)
+*
+ CALL STRMV( 'L', 'T', 'N', I-1, T, LDT, T( I, 1 ), LDT )
+*
+* T(I,I) = tau(I)
+*
+ T( I, I ) = T( 1, I )
+ T( 1, I ) = ZERO
+ END DO
+ DO I=1,M
+ DO J= I+1,M
+ T(I,J)=T(J,I)
+ T(J,I)= ZERO
+ END DO
+ END DO
+
+*
+* End of STPLQT2
+*
+ END
--- /dev/null
+*> \brief \b DTPMLQT
+*
+* =========== DOCUMENTATION ===========
+*
+* 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">
+*> [TXT]</a>
+*> \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, * ),
+* $ T( LDT, * ), WORK( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> 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
+*
+* Arguments:
+* ==========
+*
+*> \param[in] SIDE
+*> \verbatim
+*> SIDE is CHARACTER*1
+*> = 'L': apply Q or Q**T from the Left;
+*> = 'R': apply Q or Q**T from the Right.
+*> \endverbatim
+*>
+*> \param[in] TRANS
+*> \verbatim
+*> TRANS is CHARACTER*1
+*> = 'N': No transpose, apply Q;
+*> = 'T': Transpose, apply Q**T.
+*> \endverbatim
+*>
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows of the matrix B. M >= 0.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of columns of the matrix B. N >= 0.
+*> \endverbatim
+*>
+*> \param[in] K
+*> \verbatim
+*> K is INTEGER
+*> The number of elementary reflectors whose product defines
+*> the matrix Q.
+*> \endverbatim
+*>
+*> \param[in] L
+*> \verbatim
+*> L is INTEGER
+*> The order of the trapezoidal part of V.
+*> K >= L >= 0. See Further Details.
+*> \endverbatim
+*>
+*> \param[in] MB
+*> \verbatim
+*> MB is INTEGER
+*> The block size used for the storage of T. K >= MB >= 1.
+*> This must be the same value of MB used to generate T
+*> in DTPLQT.
+*> \endverbatim
+*>
+*> \param[in] V
+*> \verbatim
+*> V is REAL array, dimension (LDA,K)
+*> The i-th row must contain the vector which defines the
+*> elementary reflector H(i), for i = 1,2,...,k, as returned by
+*> DTPLQT in B. See Further Details.
+*> \endverbatim
+*>
+*> \param[in] LDV
+*> \verbatim
+*> LDV is INTEGER
+*> The leading dimension of the array V.
+*> If SIDE = 'L', LDV >= max(1,M);
+*> if SIDE = 'R', LDV >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in] T
+*> \verbatim
+*> T is REAL array, dimension (LDT,K)
+*> The upper triangular factors of the block reflectors
+*> as returned by DTPLQT, stored as a MB-by-K matrix.
+*> \endverbatim
+*>
+*> \param[in] LDT
+*> \verbatim
+*> LDT is INTEGER
+*> The leading dimension of the array T. LDT >= MB.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is REAL array, dimension
+*> (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
+*> 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.
+*> If SIDE = 'L', LDC >= max(1,K);
+*> If SIDE = 'R', LDC >= max(1,M).
+*> \endverbatim
+*>
+*> \param[in,out] B
+*> \verbatim
+*> B is REAL array, dimension (LDB,N)
+*> On entry, the M-by-N matrix B.
+*> On exit, B 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] LDB
+*> \verbatim
+*> LDB is INTEGER
+*> The leading dimension of the array B.
+*> LDB >= max(1,M).
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is REAL array. The dimension of WORK is
+*> N*MB if SIDE = 'L', or M*MB if SIDE = 'R'.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> < 0: if INFO = -i, the i-th argument had an illegal value
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2015
+*
+*> \ingroup doubleOTHERcomputational
+*
+*> \par Further Details:
+* =====================
+*>
+*> \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
+*> trapezoidal block V2:
+*>
+*> V = [V1] [V2].
+*>
+*>
+*> 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 = '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.
+*>
+*> If TRANS='N' and SIDE='L', C is on exit replaced with Q * C.
+*>
+*> If TRANS='T' and SIDE='L', C is on exit replaced with Q**T * C.
+*>
+*> If TRANS='N' and SIDE='R', C is on exit replaced with C * Q.
+*>
+*> If TRANS='T' and SIDE='R', C is on exit replaced with C * Q**T.
+*> \endverbatim
+*>
+* =====================================================================
+ SUBROUTINE STPMLQT( SIDE, TRANS, M, N, K, L, MB, V, LDV, T, LDT,
+ $ A, LDA, B, LDB, WORK, INFO )
+*
+* -- LAPACK computational routine (version 3.6.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2015
+*
+* .. 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, * ),
+ $ T( LDT, * ), WORK( * )
+* ..
+*
+* =====================================================================
+*
+* ..
+* .. Local Scalars ..
+ LOGICAL LEFT, RIGHT, TRAN, NOTRAN
+ INTEGER I, IB, NB, LB, KF, LDAQ
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL XERBLA, SLARFB
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* .. Test the input arguments ..
+*
+ INFO = 0
+ LEFT = LSAME( SIDE, 'L' )
+ RIGHT = LSAME( SIDE, 'R' )
+ TRAN = LSAME( TRANS, 'T' )
+ NOTRAN = LSAME( TRANS, 'N' )
+*
+ IF ( LEFT ) THEN
+ LDAQ = MAX( 1, K )
+ ELSE IF ( RIGHT ) THEN
+ LDAQ = MAX( 1, M )
+ END IF
+ IF( .NOT.LEFT .AND. .NOT.RIGHT ) THEN
+ INFO = -1
+ ELSE IF( .NOT.TRAN .AND. .NOT.NOTRAN ) THEN
+ INFO = -2
+ ELSE IF( M.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( K.LT.0 ) THEN
+ INFO = -5
+ ELSE IF( L.LT.0 .OR. L.GT.K ) THEN
+ INFO = -6
+ ELSE IF( MB.LT.1 .OR. (MB.GT.K .AND. K.GT.0) ) THEN
+ INFO = -7
+ ELSE IF( LDV.LT.K ) THEN
+ INFO = -9
+ ELSE IF( LDT.LT.MB ) THEN
+ INFO = -11
+ ELSE IF( LDA.LT.LDAQ ) THEN
+ INFO = -13
+ ELSE IF( LDB.LT.MAX( 1, M ) ) THEN
+ INFO = -15
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'STPMLQT', -INFO )
+ RETURN
+ END IF
+*
+* .. Quick return if possible ..
+*
+ IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) RETURN
+*
+ IF( LEFT .AND. NOTRAN ) THEN
+*
+ DO I = 1, K, MB
+ 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
+ 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
+ IB = MIN( MB, K-I+1 )
+ NB = MIN( N-L+I+IB-1, N )
+ IF( I.GE.L ) THEN
+ LB = 0
+ 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,
+ $ A( 1, I ), LDA, B, LDB, WORK, M )
+ END DO
+*
+ ELSE IF( LEFT .AND. TRAN ) THEN
+*
+ KF = ((K-1)/MB)*MB+1
+ DO I = KF, 1, -MB
+ 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
+ CALL STPRFB( 'L', 'N', '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. NOTRAN ) THEN
+*
+ KF = ((K-1)/MB)*MB+1
+ DO I = KF, 1, -MB
+ IB = MIN( MB, K-I+1 )
+ NB = MIN( N-L+I+IB-1, N )
+ IF( I.GE.L ) THEN
+ LB = 0
+ ELSE
+ 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,
+ $ A( 1, I ), LDA, B, LDB, WORK, M )
+ END DO
+*
+ END IF
+*
+ RETURN
+*
+* End of STPMLQT
+*
+ END
--- /dev/null
+*
+* Definition:
+* ===========
+*
+* 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:
+*> A = L * Q .
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows of the matrix A. M >= 0.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of columns of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is COMPLEX*16 array, dimension (LDA,N)
+*> 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
+*> (L is lower triangular if M <= N);
+*> the elements above the diagonal are the rows of
+*> blocked V representing Q (see Further Details).
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,M).
+*> \endverbatim
+*>
+*> \param[out] WORK1
+*> \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
+*> 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
+*> ZLASWLQ or ZGELQT
+*> \endverbatim
+*>
+*> \param[in] LWORK1
+*> \verbatim
+*> LWORK1 is INTEGER
+*> The dimension of the array WORK1.
+*> 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
+*> 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
+*> 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
+*> LWORK2 = -1.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> < 0: if INFO = -i, the i-th argument had an illegal value
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*> 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 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
+*> 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
+*> Further Details in LASWLQ or GELQT.
+*> \endverbatim
+*>
+* =====================================================================
+ SUBROUTINE ZGELQ( M, N, A, LDA, WORK1, LWORK1, WORK2, LWORK2,
+ $ INFO)
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd. --
+* November 2013
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, M, N, LWORK1, LWORK2
+* ..
+* .. Array Arguments ..
+ COMPLEX*16 A( LDA, * ), WORK1( * ), WORK2( * )
+* ..
+*
+* =====================================================================
+*
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY, LMINWS
+ INTEGER MB, NB, I, II, KK, MINLW1, NBLCKS
+* ..
+* .. EXTERNAL FUNCTIONS ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* .. EXTERNAL SUBROUTINES ..
+ EXTERNAL ZGELQT, ZLASWLQ, XERBLA
+* .. INTRINSIC FUNCTIONS ..
+ INTRINSIC MAX, MIN, MOD
+* ..
+* .. EXTERNAL FUNCTIONS ..
+ INTEGER ILAENV
+ EXTERNAL ILAENV
+* ..
+* .. EXECUTABLE STATEMENTS ..
+*
+* TEST THE INPUT ARGUMENTS
+*
+ INFO = 0
+*
+ LQUERY = ( LWORK1.EQ.-1 .OR. LWORK2.EQ.-1 )
+*
+* 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)
+ ELSE
+ MB = 1
+ NB = N
+ END IF
+ IF( MB.GT.MIN(M,N).OR.MB.LT.1) MB = 1
+ IF( NB.GT.N.OR.NB.LE.M) NB = N
+ MINLW1 = M + 5
+ IF ((NB.GT.M).AND.(N.GT.M)) THEN
+ IF(MOD(N-M, NB-M).EQ.0) THEN
+ NBLCKS = (N-M)/(NB-M)
+ ELSE
+ NBLCKS = (N-M)/(NB-M) + 1
+ END IF
+ ELSE
+ NBLCKS = 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)
+ $ .AND.(.NOT.LQUERY)) THEN
+ IF (LWORK1.LT.MAX(1,MB*M*NBLCKS+5)) THEN
+ LMINWS = .TRUE.
+ MB = 1
+ END IF
+ IF (LWORK1.LT.MAX(1,M*NBLCKS+5)) THEN
+ LMINWS = .TRUE.
+ NB = N
+ END IF
+ IF (LWORK2.LT.MB*M) THEN
+ LMINWS = .TRUE.
+ MB = 1
+ END IF
+ END IF
+*
+ IF( M.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -4
+ 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
+*
+ IF( INFO.EQ.0) THEN
+ WORK1(1) = 1
+ WORK1(2) = MB*M*NBLCKS+5
+ WORK1(3) = MINLW1
+ WORK1(4) = MB
+ WORK1(5) = NB
+ WORK2(1) = MB * M
+ WORK2(2) = M
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'ZGELQ', -INFO )
+ RETURN
+ ELSE IF (LQUERY) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( MIN(M,N).EQ.0 ) THEN
+ RETURN
+ END IF
+*
+* The LQ Decomposition
+*
+ 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,
+ $ LWORK2, INFO)
+ END IF
+ RETURN
+*
+* End of ZGELQ
+*
+ END
\ No newline at end of file
--- /dev/null
+*> \brief \b ZGELQT
+*
+* =========== DOCUMENTATION ===========
+*
+* 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">
+*> [TXT]</a>
+*> \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.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows of the matrix A. M >= 0.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of columns of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in] MB
+*> \verbatim
+*> MB is INTEGER
+*> The block size to be used in the blocked QR. MIN(M,N) >= MB >= 1.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \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 (L is
+*> lower triangular if M <= N); the elements above the diagonal
+*> are the rows of V.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,M).
+*> \endverbatim
+*>
+*> \param[out] T
+*> \verbatim
+*> T is COMPLEX*16 array, dimension (LDT,MIN(M,N))
+*> The upper triangular block reflectors stored in compact form
+*> as a sequence of upper triangular blocks. See below
+*> for further details.
+*> \endverbatim
+*>
+*> \param[in] LDT
+*> \verbatim
+*> LDT is INTEGER
+*> The leading dimension of the array T. LDT >= MB.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is COMPLEX*16 array, dimension (MB*N)
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> < 0: if INFO = -i, the i-th argument had an illegal value
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2013
+*
+*> \ingroup doubleGEcomputational
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*>
+*> The matrix V stores the elementary reflectors H(i) in the i-th column
+*> below the diagonal. For example, if M=5 and N=3, the matrix V is
+*>
+*> 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.
+*> 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
+*> 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
+*> for the last block) T's are stored in the NB-by-N matrix T as
+*>
+*> T = (T1 T2 ... TB).
+*> \endverbatim
+*>
+* =====================================================================
+ SUBROUTINE ZGELQT( M, N, MB, A, LDA, T, LDT, WORK, INFO )
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2013
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, LDT, M, N, MB
+* ..
+* .. Array Arguments ..
+ COMPLEX*16 A( LDA, * ), T( LDT, * ), WORK( * )
+* ..
+*
+* =====================================================================
+*
+* ..
+* .. Local Scalars ..
+ INTEGER I, IB, IINFO, K
+* ..
+* .. External Subroutines ..
+ EXTERNAL ZGELQT3, ZLARFB, XERBLA
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+ IF( M.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( MB.LT.1 .OR. (MB.GT.MIN(M,N) .AND. MIN(M,N).GT.0 ))THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -5
+ ELSE IF( LDT.LT.MB ) THEN
+ INFO = -7
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'ZGELQT', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ K = MIN( M, N )
+ IF( K.EQ.0 ) RETURN
+*
+* Blocked loop of length K
+*
+ 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+IB, I ), LDA, WORK , M-I-IB+1 )
+ END IF
+ END DO
+ RETURN
+*
+* End of ZGELQT
+*
+ END
--- /dev/null
+*> \brief \b ZGELQT3 recursively computes a LQ factorization of a general real or complex matrix using the compact WY representation of Q.
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download DGEQRT3 + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zgelqt3.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zgelqt3.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zgelqt3.f">
+*> [TXT]</a>
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* RECURSIVE SUBROUTINE ZGELQT3( M, N, A, LDA, T, LDT, INFO )
+*
+* .. Scalar Arguments ..
+* INTEGER INFO, LDA, M, N, LDT
+* ..
+* .. Array Arguments ..
+* COMPLEX*16 A( LDA, * ), T( LDT, * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> DGELQT3 recursively computes a LQ factorization of a complex M-by-N
+*> matrix A, using the compact WY representation of Q.
+*>
+*> Based on the algorithm of Elmroth and Gustavson,
+*> IBM J. Res. Develop. Vol 44 No. 4 July 2000.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows of the matrix A. M =< N.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of columns of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is COMPLEX*16 array, dimension (LDA,N)
+*> On entry, the real M-by-N matrix A. On exit, the elements on and
+*> below the diagonal contain the N-by-N lower triangular matrix L; the
+*> elements above the diagonal are the rows of V. See below for
+*> further details.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,M).
+*> \endverbatim
+*>
+*> \param[out] T
+*> \verbatim
+*> T is COMPLEX*16 array, dimension (LDT,N)
+*> The N-by-N upper triangular factor of the block reflector.
+*> The elements on and above the diagonal contain the block
+*> reflector T; the elements below the diagonal are not used.
+*> See below for further details.
+*> \endverbatim
+*>
+*> \param[in] LDT
+*> \verbatim
+*> LDT is INTEGER
+*> The leading dimension of the array T. LDT >= max(1,N).
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> < 0: if INFO = -i, the i-th argument had an illegal value
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date September 2012
+*
+*> \ingroup doubleGEcomputational
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*>
+*> The matrix V stores the elementary reflectors H(i) in the i-th column
+*> below the diagonal. For example, if M=5 and N=3, the matrix V is
+*>
+*> 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
+*> block reflector H is then given by
+*>
+*> H = I - V * T * V**T
+*>
+*> where V**T is the transpose of V.
+*>
+*> For details of the algorithm, see Elmroth and Gustavson (cited above).
+*> \endverbatim
+*>
+* =====================================================================
+ RECURSIVE SUBROUTINE ZGELQT3( M, N, A, LDA, T, LDT, INFO )
+*
+* -- LAPACK computational routine (version 3.4.2) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* September 2012
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, M, N, LDT
+* ..
+* .. Array Arguments ..
+ COMPLEX*16 A( LDA, * ), T( LDT, * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ COMPLEX*16 ONE, ZERO
+ PARAMETER ( ONE = (1.0D+00,0.0D+00) )
+ PARAMETER ( ZERO = (0.0D+00,0.0D+00))
+* ..
+* .. Local Scalars ..
+ INTEGER I, I1, J, J1, N1, N2, IINFO
+* ..
+* .. External Subroutines ..
+ EXTERNAL ZLARFG, ZTRMM, ZGEMM, XERBLA
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+ IF( M .LT. 0 ) THEN
+ INFO = -1
+ ELSE IF( N .LT. M ) THEN
+ INFO = -2
+ ELSE IF( LDA .LT. MAX( 1, M ) ) THEN
+ INFO = -4
+ ELSE IF( LDT .LT. MAX( 1, M ) ) THEN
+ INFO = -6
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'ZGELQT3', -INFO )
+ RETURN
+ END IF
+*
+ IF( M.EQ.1 ) THEN
+*
+* Compute Householder transform when N=1
+*
+ CALL ZLARFG( N, A, A( 1, MIN( 2, N ) ), LDA, T )
+ T(1,1)=CONJG(T(1,1))
+*
+ ELSE
+*
+* Otherwise, split A into blocks...
+*
+ M1 = M/2
+ M2 = M-M1
+ I1 = MIN( M1+1, M )
+ J1 = MIN( M+1, N )
+*
+* Compute A(1:M1,1:N) <- (Y1,R1,T1), where Q1 = I - Y1 T1 Y1^H
+*
+ CALL ZGELQT3( M1, N, A, LDA, T, LDT, IINFO )
+*
+* Compute A(J1:M,1:N) = A(J1:M,1:N) Q1^H [workspace: T(1:N1,J1:N)]
+*
+ DO I=1,M2
+ DO J=1,M1
+ T( I+M1, J ) = A( I+M1, J )
+ END DO
+ END DO
+ CALL ZTRMM( 'R', 'U', 'C', 'U', M2, M1, ONE,
+ & A, LDA, T( I1, 1 ), LDT )
+*
+ CALL ZGEMM( 'N', 'C', M2, M1, N-M1, ONE, A( I1, I1 ), LDA,
+ & A( 1, I1 ), LDA, ONE, T( I1, 1 ), LDT)
+*
+ CALL ZTRMM( 'R', 'U', 'N', 'N', M2, M1, ONE,
+ & T, LDT, T( I1, 1 ), LDT )
+*
+ CALL ZGEMM( 'N', 'N', M2, N-M1, M1, -ONE, T( I1, 1 ), LDT,
+ & A( 1, I1 ), LDA, ONE, A( I1, I1 ), LDA )
+*
+ CALL ZTRMM( 'R', 'U', 'N', 'U', M2, M1 , ONE,
+ & A, LDA, T( I1, 1 ), LDT )
+*
+ DO I=1,M2
+ DO J=1,M1
+ A( I+M1, J ) = A( I+M1, J ) - T( I+M1, J )
+ T( I+M1, J )= ZERO
+ END DO
+ END DO
+*
+* Compute A(J1:M,J1:N) <- (Y2,R2,T2) where Q2 = I - Y2 T2 Y2^H
+*
+ CALL ZGELQT3( M2, N-M1, A( I1, I1 ), LDA,
+ & T( I1, I1 ), LDT, IINFO )
+*
+* Compute T3 = T(J1:N1,1:N) = -T1 Y1^H Y2 T2
+*
+ DO I=1,M2
+ DO J=1,M1
+ T( J, I+M1 ) = (A( J, I+M1 ))
+ END DO
+ END DO
+*
+ CALL ZTRMM( 'R', 'U', 'C', 'U', M1, M2, ONE,
+ & A( I1, I1 ), LDA, T( 1, I1 ), LDT )
+*
+ CALL ZGEMM( 'N', 'C', M1, M2, N-M, ONE, A( 1, J1 ), LDA,
+ & A( I1, J1 ), LDA, ONE, T( 1, I1 ), LDT )
+*
+ CALL ZTRMM( 'L', 'U', 'N', 'N', M1, M2, -ONE, T, LDT,
+ & T( 1, I1 ), LDT )
+*
+ CALL ZTRMM( '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]
+*
+ END IF
+*
+ RETURN
+*
+* End of ZGELQT3
+*
+ END
--- /dev/null
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZGEMLQ( SIDE, TRANS, M, N, K, A, LDA, WORK1,
+* $ LWORK1, C, LDC, WORK2, LWORK2, INFO )
+*
+*
+* .. Scalar Arguments ..
+* CHARACTER SIDE, TRANS
+* INTEGER INFO, LDA, M, N, K, MB, NB, LWORK1, LWORK2, LDC
+* ..
+* .. Array Arguments ..
+* COMPLEX*16 A( LDA, * ), WORK1( * ), C(LDC, * ),
+* $ WORK2( * )
+*> \par Purpose:
+* =============
+*>
+*> \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
+*> factorization (DGELQ)
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] SIDE
+*> SIDE is CHARACTER*1
+*> = 'L': apply Q or Q**T from the Left;
+*> = 'R': apply Q or Q**T from the Right.
+*>
+*> \param[in] TRANS
+*> TRANS is CHARACTER*1
+*> = 'N': No transpose, apply Q;
+*> = 'T': Transpose, apply Q**T.
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows of the matrix A. M >=0.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of columns of the matrix C. N >= M.
+*> \endverbatim
+*>
+*> \param[in] K
+*> \verbatim
+*> K is INTEGER
+*> The number of elementary reflectors whose product defines
+*> the matrix Q.
+*> M >= K >= 0;
+*>
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is COMPLEX*16 array, dimension (LDA,K)
+*> The i-th row must contain the vector which defines the blocked
+*> elementary reflector H(i), for i = 1,2,...,k, as returned by
+*> DLASWLQ in the first k rows of its array argument A.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A.
+*> If SIDE = 'L', LDA >= max(1,M);
+*> if SIDE = 'R', LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in] WORK1
+*> \verbatim
+*> WORK1 is COMPLEX*16 array, dimension (MAX(1,LWORK1)) is
+*> returned by GEQR.
+*> \endverbatim
+*>
+*> \param[in] LWORK1
+*> \verbatim
+*> LWORK1 is INTEGER
+*> The dimension of the array WORK1.
+*> \endverbatim
+*>
+*> \param[in,out] C
+*> C is COMPLEX*16 array, dimension (LDC,N)
+*> On entry, the M-by-N matrix C.
+*> On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.
+*> \param[in] LDC
+*> LDC is INTEGER
+*> The leading dimension of the array C. LDC >= max(1,M).
+*>
+*> \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 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)),
+*> and no error message related to LWORK2 is issued by XERBLA.
+*>
+*> \endverbatim
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> < 0: if INFO = -i, the i-th argument had an illegal value
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*> 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 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
+*> 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
+*> Further Details in LASWLQ or GELQT.
+*> \endverbatim
+*>
+* =====================================================================
+ SUBROUTINE ZGEMLQ( SIDE, TRANS, M, N, K, A, LDA, WORK1, LWORK1,
+ $ C, LDC, WORK2, LWORK2, INFO )
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2013
+*
+* .. Scalar Arguments ..
+ CHARACTER SIDE, TRANS
+ INTEGER INFO, LDA, M, N, K, LWORK1, LWORK2, LDC
+* ..
+* .. Array Arguments ..
+ COMPLEX*16 A( LDA, * ), C( LDC, * ), WORK1( * ), WORK2( * )
+* ..
+*
+* =====================================================================
+*
+* ..
+* .. Local Scalars ..
+ LOGICAL LEFT, RIGHT, TRAN, NOTRAN, LQUERY
+ INTEGER I, II, KK, MB, NB, LW, NBLCKS, MN
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* .. External Subroutines ..
+ EXTERNAL ZLAMSWLQ, ZGEMLQT, XERBLA
+* .. Intrinsic Functions ..
+ INTRINSIC INT, MAX, MIN, MOD
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ LQUERY = LWORK2.LT.0
+ NOTRAN = LSAME( TRANS, 'N' )
+ TRAN = LSAME( TRANS, 'C' )
+ LEFT = LSAME( SIDE, 'L' )
+ RIGHT = LSAME( SIDE, 'R' )
+*
+ MB = INT(WORK1(4))
+ NB = INT(WORK1(5))
+ IF (LEFT) THEN
+ LW = N * MB
+ MN = M
+ ELSE
+ LW = M * MB
+ MN = N
+ END IF
+ IF ((NB.GT.K).AND.(MN.GT.K)) THEN
+ IF(MOD(MN-K, NB-K).EQ.0) THEN
+ NBLCKS = (MN-K)/(NB-K)
+ ELSE
+ NBLCKS = (MN-K)/(NB-K) + 1
+ END IF
+ ELSE
+ NBLCKS = 1
+ END IF
+*
+ INFO = 0
+ IF( .NOT.LEFT .AND. .NOT.RIGHT ) THEN
+ INFO = -1
+ ELSE IF( .NOT.TRAN .AND. .NOT.NOTRAN ) THEN
+ INFO = -2
+ ELSE IF( M.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( N.LT.0) THEN
+ INFO = -4
+ ELSE IF( K.LT.0 ) THEN
+ INFO = -5
+ ELSE IF( LDA.LT.MAX( 1, K ) ) THEN
+ INFO = -7
+ ELSE IF( LWORK1.LT.MAX( 1, MB*K*NBLCKS+5 )) THEN
+ INFO = -9
+ ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
+ INFO = -11
+ ELSE IF(( LWORK2.LT.MAX(1,LW)).AND.(.NOT.LQUERY)) THEN
+ INFO = -13
+ END IF
+*
+ IF( INFO.EQ.0) THEN
+ WORK2(1) = LW
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'ZGEMLQ', -INFO )
+ RETURN
+ ELSE IF (LQUERY) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( MIN(M,N,K).EQ.0 ) THEN
+ RETURN
+ 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)
+ ELSE
+ CALL ZLAMSWLQ( SIDE, TRANS, M, N, K, MB, NB, A, LDA, WORK1(6),
+ $ MB, C, LDC, WORK2, LWORK2, INFO )
+ END IF
+*
+ WORK2(1) = LW
+ RETURN
+*
+* End of ZGEMLQ
+*
+ END
\ No newline at end of file
--- /dev/null
+*> \brief \b ZGEMLQT
+*
+* =========== DOCUMENTATION ===========
+*
+* 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">
+*> [TXT]</a>
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* 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:
+* =============
+*>
+*> \verbatim
+*>
+*> ZGEMQRT overwrites the general real 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 complex orthogonal matrix defined as the product of K
+*> elementary reflectors:
+*>
+*> Q = H(1) H(2) . . . H(K) = I - V C V**C
+*>
+*> 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
+*
+* Arguments:
+* ==========
+*
+*> \param[in] SIDE
+*> \verbatim
+*> SIDE is CHARACTER*1
+*> = 'L': apply Q or Q**C from the Left;
+*> = 'R': apply Q or Q**C from the Right.
+*> \endverbatim
+*>
+*> \param[in] TRANS
+*> \verbatim
+*> TRANS is CHARACTER*1
+*> = 'N': No transpose, apply Q;
+*> = 'C': Transpose, apply Q**C.
+*> \endverbatim
+*>
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows of the matrix C. M >= 0.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of columns of the matrix C. N >= 0.
+*> \endverbatim
+*>
+*> \param[in] K
+*> \verbatim
+*> K is INTEGER
+*> The number of elementary reflectors whose product defines
+*> the matrix Q.
+*> If SIDE = 'L', M >= K >= 0;
+*> if SIDE = 'R', N >= K >= 0.
+*> \endverbatim
+*>
+*> \param[in] MB
+*> \verbatim
+*> MB is INTEGER
+*> The block size used for the storage of T. K >= MB >= 1.
+*> This must be the same value of MB used to generate T
+*> in DGELQT.
+*> \endverbatim
+*>
+*> \param[in] V
+*> \verbatim
+*> V is COMPLEX*16 array, dimension (LDV,K)
+*> The i-th row must contain the vector which defines the
+*> elementary reflector H(i), for i = 1,2,...,k, as returned by
+*> DGELQT in the first K rows of its array argument A.
+*> \endverbatim
+*>
+*> \param[in] LDV
+*> \verbatim
+*> LDV is INTEGER
+*> The leading dimension of the array V.
+*> If SIDE = 'L', LDA >= max(1,M);
+*> if SIDE = 'R', LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in] T
+*> \verbatim
+*> T is COMPLEX*16 array, dimension (LDT,K)
+*> The upper triangular factors of the block reflectors
+*> as returned by DGELQT, stored as a MB-by-M matrix.
+*> \endverbatim
+*>
+*> \param[in] LDT
+*> \verbatim
+*> LDT is INTEGER
+*> The leading dimension of the array T. LDT >= MB.
+*> \endverbatim
+*>
+*> \param[in,out] C
+*> \verbatim
+*> C is COMPLEX*16 array, dimension (LDC,N)
+*> On entry, the M-by-N matrix C.
+*> On exit, C is overwritten by Q C, Q**C C, C Q**C or C Q.
+*> \endverbatim
+*>
+*> \param[in] LDC
+*> \verbatim
+*> LDC is INTEGER
+*> The leading dimension of the array C. LDC >= max(1,M).
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is COMPLEX*16 array. The dimension of
+*> WORK is N*MB if SIDE = 'L', or M*MB if SIDE = 'R'.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> < 0: if INFO = -i, the i-th argument had an illegal value
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2013
+*
+*> \ingroup doubleGEcomputational
+*
+* =====================================================================
+ SUBROUTINE ZGEMLQT( SIDE, TRANS, M, N, K, MB, V, LDV, T, LDT,
+ $ C, LDC, WORK, INFO )
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2013
+*
+* .. Scalar Arguments ..
+ CHARACTER SIDE, TRANS
+ INTEGER INFO, K, LDV, LDC, M, N, MB, LDT
+* ..
+* .. Array Arguments ..
+ COMPLEX*16 V( LDV, * ), C( LDC, * ), T( LDT, * ), WORK( * )
+* ..
+*
+* =====================================================================
+*
+* ..
+* .. Local Scalars ..
+ LOGICAL LEFT, RIGHT, TRAN, NOTRAN
+ INTEGER I, IB, LDWORK, KF, Q
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL XERBLA, ZLARFB
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* .. Test the input arguments ..
+*
+ INFO = 0
+ LEFT = LSAME( SIDE, 'L' )
+ RIGHT = LSAME( SIDE, 'R' )
+ TRAN = LSAME( TRANS, 'C' )
+ NOTRAN = LSAME( TRANS, 'N' )
+*
+ IF( LEFT ) THEN
+ LDWORK = MAX( 1, N )
+ ELSE IF ( RIGHT ) THEN
+ LDWORK = MAX( 1, M )
+ END IF
+ IF( .NOT.LEFT .AND. .NOT.RIGHT ) THEN
+ INFO = -1
+ ELSE IF( .NOT.TRAN .AND. .NOT.NOTRAN ) THEN
+ INFO = -2
+ ELSE IF( M.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( K.LT.0) THEN
+ INFO = -5
+ ELSE IF( MB.LT.1 .OR. (MB.GT.K .AND. K.GT.0)) THEN
+ INFO = -6
+ ELSE IF( LDV.LT.MAX( 1, K ) ) THEN
+ INFO = -8
+ ELSE IF( LDT.LT.MB ) THEN
+ INFO = -10
+ ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
+ INFO = -12
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'ZGEMLQT', -INFO )
+ RETURN
+ END IF
+*
+* .. Quick return if possible ..
+*
+ IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) RETURN
+*
+ IF( LEFT .AND. NOTRAN ) 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,
+ $ 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,
+ $ C( 1, I ), LDC, WORK, LDWORK )
+ END DO
+*
+ ELSE IF( LEFT .AND. TRAN ) THEN
+*
+ 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,
+ $ C( I, 1 ), LDC, WORK, LDWORK )
+ END DO
+*
+ ELSE IF( RIGHT .AND. NOTRAN ) THEN
+*
+ 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,
+ $ C( 1, I ), LDC, WORK, LDWORK )
+ END DO
+*
+ END IF
+*
+ RETURN
+*
+* End of ZGEMLQT
+*
+ END
--- /dev/null
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZGEMQR( SIDE, TRANS, M, N, K, A, LDA, WORK1,
+* $ LWORK1, C, LDC, WORK2, LWORK2, INFO )
+*
+*
+* .. Scalar Arguments ..
+* CHARACTER SIDE, TRANS
+* INTEGER INFO, LDA, M, N, K, LDT, LWORK1, LWORK2, LDC
+* ..
+* .. Array Arguments ..
+* COMPLEX*16 A( LDA, * ), WORK1( * ), C(LDC, * ),
+* $ WORK2( * )
+*> \par Purpose:
+* =============
+*>
+*> \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
+*> QR factorization (ZGEQR)
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] SIDE
+*> SIDE is CHARACTER*1
+*> = 'L': apply Q or Q**T from the Left;
+*> = 'R': apply Q or Q**T from the Right.
+*>
+*> \param[in] TRANS
+*> TRANS is CHARACTER*1
+*> = 'N': No transpose, apply Q;
+*> = 'T': Transpose, apply Q**T.
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows of the matrix A. M >=0.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of columns of the matrix C. M >= N >= 0.
+*> \endverbatim
+*>
+*> \param[in] K
+*> \verbatim
+*> K is INTEGER
+*> The number of elementary reflectors whose product defines
+*> the matrix Q.
+*> N >= K >= 0;
+*>
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is COMPLEX*16 array, dimension (LDA,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
+*> its array argument A.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A.
+*> If SIDE = 'L', LDA >= max(1,M);
+*> if SIDE = 'R', LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in] WORK1
+*> \verbatim
+*> WORK1 is COMPLEX*16 array, dimension (MAX(1,LWORK1)) as
+*> it is returned by GEQR.
+*> \endverbatim
+*>
+*> \param[in] LWORK1
+*> \verbatim
+*> LWORK1 is INTEGER
+*> The dimension of the array WORK1.
+*> \endverbatim
+*>
+*> \param[in,out] C
+*> C is COMPLEX*16 array, dimension (LDC,N)
+*> On entry, the M-by-N matrix C.
+*> On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.
+*>
+*> \param[in] LDC
+*> LDC is INTEGER
+*> The leading dimension of the array C. LDC >= max(1,M).
+*>
+*> \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 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)),
+*> and no error message related to LWORK2 is issued by XERBLA.
+*>
+*> \endverbatim
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> < 0: if INFO = -i, the i-th argument had an illegal value
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*> 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 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
+*> Further Details in LATSQR or GEQRT.
+*> \endverbatim
+*>
+* =====================================================================
+ SUBROUTINE ZGEMQR( SIDE, TRANS, M, N, K, A, LDA, WORK1, LWORK1,
+ $ C, LDC, WORK2, LWORK2, INFO )
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2013
+*
+* .. Scalar Arguments ..
+ CHARACTER SIDE, TRANS
+ INTEGER INFO, LDA, M, N, K, LWORK1, LWORK2, LDC
+* ..
+* .. Array Arguments ..
+ COMPLEX*16 A( LDA, * ), WORK1( * ), C(LDC, * ),
+ $ WORK2( * )
+* ..
+*
+* =====================================================================
+*
+* ..
+* .. Local Scalars ..
+ LOGICAL LEFT, RIGHT, TRAN, NOTRAN, LQUERY
+ INTEGER MB, NB, I, II, KK, LW, NBLCKS, MN
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* .. External Subroutines ..
+ EXTERNAL ZGEMQRT, ZLAMTSQR, XERBLA
+* .. Intrinsic Functions ..
+ INTRINSIC INT, MAX, MIN, MOD
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ LQUERY = LWORK2.LT.0
+ NOTRAN = LSAME( TRANS, 'N' )
+ TRAN = LSAME( TRANS, 'C' )
+ LEFT = LSAME( SIDE, 'L' )
+ RIGHT = LSAME( SIDE, 'R' )
+*
+ MB = INT(WORK1(4))
+ NB = INT(WORK1(5))
+ IF(LEFT) THEN
+ LW = N * NB
+ MN = M
+ ELSE IF(RIGHT) THEN
+ LW = MB * NB
+ MN = N
+ END IF
+*
+ IF ((MB.GT.K).AND.(MN.GT.K)) THEN
+ IF(MOD(MN-K, MB-K).EQ.0) THEN
+ NBLCKS = (MN-K)/(MB-K)
+ ELSE
+ NBLCKS = (MN-K)/(MB-K) + 1
+ END IF
+ ELSE
+ NBLCKS = 1
+ END IF
+*
+ INFO = 0
+ IF( .NOT.LEFT .AND. .NOT.RIGHT ) THEN
+ INFO = -1
+ ELSE IF( .NOT.TRAN .AND. .NOT.NOTRAN ) THEN
+ INFO = -2
+ ELSE IF( M.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( K.LT.0 ) THEN
+ INFO = -5
+ ELSE IF( LDA.LT.MAX( 1, K ) ) THEN
+ INFO = -7
+ ELSE IF( LWORK1.LT.MAX( 1, NB*K*NBLCKS+5 )) THEN
+ INFO = -9
+ ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
+ INFO = -11
+ ELSE IF(( LWORK2.LT.MAX(1,LW)).AND.(.NOT.LQUERY)) THEN
+ INFO = -13
+ 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( INFO.NE.0 ) THEN
+ CALL XERBLA( 'ZGEMQR', -INFO )
+ RETURN
+ ELSE IF (LQUERY) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( MIN(M,N,K).EQ.0 ) THEN
+ RETURN
+ 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 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
+*
+ WORK2(1) = LW
+ RETURN
+*
+* End of DGEMQR
+*
+ END
\ No newline at end of file
--- /dev/null
+*
+* 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:
+*> A = Q * R .
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows of the matrix A. M >= 0.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of columns of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is COMPLEX*16 array, dimension (LDA,N)
+*> 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
+*> (R is upper triangular if M >= N);
+*> the elements below the diagonal represent Q (see Further Details).
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,M).
+*> \endverbatim
+*>
+*> \param[out] WORK1
+*> \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
+*> 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
+*> CLATSQR or CGEQRT
+*> \endverbatim
+*>
+*> \param[in] LWORK1
+*> \verbatim
+*> LWORK1 is INTEGER
+*> The dimension of the array WORK1.
+*> 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
+*> 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
+*> 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
+*> LWORK2 = -1.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> < 0: if INFO = -i, the i-th argument had an illegal value
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*> 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 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
+*> Further Details in LATSQR or GEQRT.
+*> \endverbatim
+*>
+* =====================================================================
+ SUBROUTINE ZGEQR( M, N, A, LDA, WORK1, LWORK1, WORK2, LWORK2,
+ $ INFO)
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd. --
+* November 2013
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, M, N, LWORK1, LWORK2
+* ..
+* .. Array Arguments ..
+ COMPLEX*16 A( LDA, * ), WORK1( * ), WORK2( * )
+* ..
+*
+* =====================================================================
+*
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY, LMINWS
+ INTEGER MB, NB, I, II, KK, MINLW1, NBLCKS
+* ..
+* .. EXTERNAL FUNCTIONS ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* .. EXTERNAL SUBROUTINES ..
+ EXTERNAL ZLATSQR, ZGEQRT, XERBLA
+* .. INTRINSIC FUNCTIONS ..
+ INTRINSIC MAX, MIN, MOD
+* ..
+* .. EXTERNAL FUNCTIONS ..
+ INTEGER ILAENV
+ EXTERNAL ILAENV
+* ..
+* .. EXECUTABLE STATEMENTS ..
+*
+* TEST THE INPUT ARGUMENTS
+*
+ INFO = 0
+*
+ LQUERY = ( LWORK1.EQ.-1 .OR. LWORK2.EQ.-1 )
+*
+* 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)
+ ELSE
+ MB = M
+ NB = 1
+ END IF
+ IF( MB.GT.M.OR.MB.LE.N) MB = M
+ IF( NB.GT.MIN(M,N).OR.NB.LT.1) NB = 1
+ MINLW1 = N + 5
+ IF ((MB.GT.N).AND.(M.GT.N)) THEN
+ IF(MOD(M-N, MB-N).EQ.0) THEN
+ NBLCKS = (M-N)/(MB-N)
+ ELSE
+ NBLCKS = (M-N)/(MB-N) + 1
+ END IF
+ ELSE
+ NBLCKS = 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)
+ $ .AND.(.NOT.LQUERY)) THEN
+ IF (LWORK1.LT.MAX(1, NB * N * NBLCKS+5)) THEN
+ LMINWS = .TRUE.
+ NB = 1
+ END IF
+ IF (LWORK1.LT.MAX(1, N * NBLCKS+5)) THEN
+ LMINWS = .TRUE.
+ MB = M
+ END IF
+ IF (LWORK2.LT.NB*N) THEN
+ LMINWS = .TRUE.
+ NB = 1
+ END IF
+ END IF
+*
+ IF( M.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -4
+ 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)
+ $ .AND.(.NOT.LMINWS)) THEN
+ INFO = -8
+ END IF
+
+ IF( INFO.EQ.0) THEN
+ WORK1(1) = 1
+ WORK1(2) = NB * N * NBLCKS + 5
+ WORK1(3) = MINLW1
+ WORK1(4) = MB
+ WORK1(5) = NB
+ WORK2(1) = NB * N
+ WORK2(2) = N
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'ZGEQR', -INFO )
+ RETURN
+ ELSE IF (LQUERY) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( MIN(M,N).EQ.0 ) THEN
+ RETURN
+ END IF
+*
+* The QR Decomposition
+*
+ 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,
+ $ LWORK2, INFO)
+ END IF
+ RETURN
+*
+* End of ZGEQR
+*
+ END
\ No newline at end of file
--- /dev/null
+* Definition:
+* ===========
+*
+* SUBROUTINE ZGETSLS( 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 ..
+* COMPLEX*16 A( LDA, * ), B( LDB, * ), WORK( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> ZGETSLS solves overdetermined or underdetermined real linear systems
+*> involving an M-by-N matrix A, or its transpose, using a tall skinny
+*> QR or short wide LQfactorization of A. It is assumed that A has
+*> full rank.
+*>
+*> The following options are provided:
+*>
+*> 1. If TRANS = 'N' and m >= n: find the least squares solution of
+*> an overdetermined system, i.e., solve the least squares problem
+*> minimize || B - A*X ||.
+*>
+*> 2. If TRANS = 'N' and m < n: find the minimum norm solution of
+*> an underdetermined system A * X = B.
+*>
+*> 3. If TRANS = 'C' and m >= n: find the minimum norm solution of
+*> an undetermined system A**T * X = B.
+*>
+*> 4. If TRANS = 'C' and m < n: find the least squares solution of
+*> an overdetermined system, i.e., solve the least squares problem
+*> minimize || B - A**T * X ||.
+*>
+*> Several right hand side vectors b and solution vectors x can be
+*> handled in a single call; they are stored as the columns of the
+*> M-by-NRHS right hand side matrix B and the N-by-NRHS solution
+*> matrix X.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] TRANS
+*> \verbatim
+*> TRANS is CHARACTER*1
+*> = 'N': the linear system involves A;
+*> = 'C': the linear system involves A**C.
+*> \endverbatim
+*>
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows of the matrix A. M >= 0.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of columns of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in] NRHS
+*> \verbatim
+*> NRHS is INTEGER
+*> The number of right hand sides, i.e., the number of
+*> columns of the matrices B and X. NRHS >=0.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is COMPLEX*16 array, dimension (LDA,N)
+*> On entry, the M-by-N matrix A.
+*> On exit,
+*> if M >= N, A is overwritten by details of its QR
+*> factorization as returned by DGEQRF;
+*> if M < N, A is overwritten by details of its LQ
+*> factorization as returned by DGELQF.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,M).
+*> \endverbatim
+*>
+*> \param[in,out] B
+*> \verbatim
+*> B is COMPLEX*16 array, dimension (LDB,NRHS)
+*> On entry, the matrix B of right hand side vectors, stored
+*> columnwise; B is M-by-NRHS if TRANS = 'N', or N-by-NRHS
+*> if TRANS = 'T'.
+*> On exit, if INFO = 0, B is overwritten by the solution
+*> vectors, stored columnwise:
+*> if TRANS = 'N' and m >= n, rows 1 to n of B contain the least
+*> squares solution vectors; the residual sum of squares for the
+*> solution in each column is given by the sum of squares of
+*> elements N+1 to M in that column;
+*> if TRANS = 'N' and m < n, rows 1 to N of B contain the
+*> minimum norm solution vectors;
+*> if TRANS = 'T' and m >= n, rows 1 to M of B contain the
+*> minimum norm solution vectors;
+*> if TRANS = 'T' and m < n, rows 1 to M of B contain the
+*> least squares solution vectors; the residual sum of squares
+*> for the solution in each column is given by the sum of
+*> squares of elements M+1 to N in that column.
+*> \endverbatim
+*>
+*> \param[in] LDB
+*> \verbatim
+*> LDB is INTEGER
+*> The leading dimension of the array B. LDB >= MAX(1,M,N).
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
+*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*> \endverbatim
+*>
+*> \param[in] LWORK
+*> \verbatim
+*> LWORK is INTEGER
+*> The dimension of the array WORK.
+*> LWORK >= max( 1, MN + max( MN, NRHS ) ).
+*> For optimal performance,
+*> LWORK >= max( 1, MN + max( MN, NRHS )*NB ).
+*> where MN = min(M,N) and NB is the optimum block size.
+*>
+*> If LWORK = -1, then a workspace query is assumed; the routine
+*> only calculates the optimal size of the WORK array, returns
+*> this value as the first entry of the WORK array, and no error
+*> message related to LWORK is issued by XERBLA.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> < 0: if INFO = -i, the i-th argument had an illegal value
+*> > 0: if INFO = i, the i-th diagonal element of the
+*> triangular factor of A is zero, so that A does not have
+*> full rank; the least squares solution could not be
+*> computed.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2011
+*
+* =====================================================================
+ SUBROUTINE ZGETSLS( TRANS, M, N, NRHS, A, LDA, B, LDB
+ $ , WORK, LWORK, INFO )
+*
+* -- LAPACK driver routine (version 3.4.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2011
+*
+* .. Scalar Arguments ..
+ CHARACTER TRANS
+ INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS, MB
+* ..
+* .. Array Arguments ..
+ COMPLEX*16 A( LDA, * ), B( LDB, * ), WORK( * )
+*
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
+ COMPLEX*16 CZERO
+ PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ) )
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY, TRAN
+ INTEGER I, IASCL, IBSCL, J, MINMN, MAXMN, BROW, LW,
+ $ SCLLEN, MNK, WSIZEO, WSIZEM, LW1, LW2, INFO2
+ DOUBLE PRECISION ANRM, BIGNUM, BNRM, SMLNUM
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ DOUBLE PRECISION DLAMCH, ZLANGE
+ EXTERNAL LSAME, ILAENV, DLABAD, DLAMCH, DLANGE
+* ..
+* .. External Subroutines ..
+ EXTERNAL ZGEQR, ZGEMQR, ZLASCL, ZLASET,
+ $ ZTRTRS, XERBLA, ZGELQ, ZGEMLQ
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC DBLE, MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments.
+*
+ INFO=0
+ MINMN = MIN( M, N )
+ MAXMN = MAX( M, N )
+ MNK = MAX(MINMN,NRHS)
+ TRAN = LSAME( TRANS, 'C' )
+*
+ LQUERY = ( LWORK.EQ.-1 )
+ IF( .NOT.( LSAME( TRANS, 'N' ) .OR.
+ $ LSAME( TRANS, 'C' ) ) ) THEN
+ INFO = -1
+ ELSE IF( M.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -6
+ ELSE IF( LDB.LT.MAX( 1, M, N ) ) THEN
+ INFO = -8
+ END IF
+*
+ IF( INFO.EQ.0) THEN
+*
+* Determine the block size and minimum LWORK
+*
+ IF ( M.GE.N ) THEN
+ CALL ZGEQR( M, N, A, LDA, WORK(1), -1, WORK(6), -1,
+ $ INFO2)
+ MB = INT(WORK(4))
+ NB = INT(WORK(5))
+ LW = INT(WORK(6))
+ CALL ZGEMQR( 'L', TRANS, M, NRHS, N, A, LDA, WORK(1),
+ $ 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 ZGELQ( M, N, A, LDA, WORK(1), -1, WORK(6), -1,
+ $ INFO2)
+ MB = INT(WORK(4))
+ NB = INT(WORK(5))
+ LW = INT(WORK(6))
+ CALL ZGEMLQ( 'L', TRANS, N, NRHS, M, A, LDA, WORK(1),
+ $ 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)))
+ END IF
+*
+ IF((LWORK.LT.WSIZEO).AND.(.NOT.LQUERY)) THEN
+ INFO=-10
+ END IF
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'ZGETSLS', -INFO )
+ WORK( 1 ) = DBLE( WSIZEO )
+ WORK( 2 ) = DBLE( WSIZEM )
+ RETURN
+ ELSE IF (LQUERY) THEN
+ WORK( 1 ) = DBLE( WSIZEO )
+ WORK( 2 ) = DBLE( WSIZEM )
+ RETURN
+ END IF
+ IF(LWORK.LT.WSIZEO) THEN
+ LW1=INT(WORK(3))
+ LW2=MAX(LW,INT(WORK(6)))
+ ELSE
+ LW1=INT(WORK(2))
+ LW2=MAX(LW,INT(WORK(6)))
+ END IF
+*
+* Quick return if possible
+*
+ IF( MIN( M, N, NRHS ).EQ.0 ) THEN
+ CALL ZLASET( 'FULL', MAX( M, N ), NRHS, CZERO, CZERO,
+ $ B, LDB )
+ RETURN
+ END IF
+*
+* Get machine parameters
+*
+ SMLNUM = DLAMCH( 'S' ) / DLAMCH( 'P' )
+ BIGNUM = ONE / SMLNUM
+ CALL DLABAD( SMLNUM, BIGNUM )
+*
+* Scale A, B if max element outside range [SMLNUM,BIGNUM]
+*
+ ANRM = ZLANGE( 'M', M, N, A, LDA, RWORK )
+ IASCL = 0
+ IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
+*
+* Scale matrix norm up to SMLNUM
+*
+ CALL ZLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, INFO )
+ IASCL = 1
+ ELSE IF( ANRM.GT.BIGNUM ) THEN
+*
+* Scale matrix norm down to BIGNUM
+*
+ CALL ZLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, INFO )
+ IASCL = 2
+ ELSE IF( ANRM.EQ.ZERO ) THEN
+*
+* Matrix all zero. Return zero solution.
+*
+ CALL ZLASET( 'F', MAXMN, NRHS, CZERO, CZERO, B, LDB )
+ GO TO 50
+ END IF
+*
+ BROW = M
+ IF ( TRAN ) THEN
+ BROW = N
+ END IF
+ BNRM = ZLANGE( 'M', BROW, NRHS, B, LDB, RWORK )
+ IBSCL = 0
+ IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
+*
+* Scale matrix norm up to SMLNUM
+*
+ CALL ZLASCL( 'G', 0, 0, BNRM, SMLNUM, BROW, NRHS, B, LDB,
+ $ INFO )
+ IBSCL = 1
+ ELSE IF( BNRM.GT.BIGNUM ) THEN
+*
+* Scale matrix norm down to BIGNUM
+*
+ CALL ZLASCL( 'G', 0, 0, BNRM, BIGNUM, BROW, NRHS, B, LDB,
+ $ INFO )
+ IBSCL = 2
+ END IF
+*
+ IF ( M.GE.N) THEN
+*
+* compute QR factorization of A
+*
+ CALL ZGEQR( M, N, A, LDA, WORK(LW2+1), LW1
+ $ , WORK(1), LW2, INFO )
+ IF (.NOT.TRAN) THEN
+*
+* Least-Squares Problem min || A * X - B ||
+*
+* B(1:M,1:NRHS) := Q**T * B(1:M,1:NRHS)
+*
+ CALL ZGEMQR( 'L' , 'C', 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 ZTRTRS( 'U', 'N', 'N', N, NRHS,
+ $ A, LDA, B, LDB, INFO )
+ IF(INFO.GT.0) THEN
+ RETURN
+ END IF
+ SCLLEN = N
+ ELSE
+*
+* Overdetermined system of equations A**T * X = B
+*
+* B(1:N,1:NRHS) := inv(R**T) * B(1:N,1:NRHS)
+*
+ CALL ZTRTRS( 'U', 'C', 'N', N, NRHS,
+ $ A, LDA, B, LDB, INFO )
+*
+ IF( INFO.GT.0 ) THEN
+ RETURN
+ END IF
+*
+* B(N+1:M,1:NRHS) = CZERO
+*
+ DO 20 J = 1, NRHS
+ DO 10 I = N + 1, M
+ B( I, J ) = CZERO
+ 10 CONTINUE
+ 20 CONTINUE
+*
+* B(1:M,1:NRHS) := Q(1:N,:) * B(1:N,1:NRHS)
+*
+ CALL ZGEMQR( 'L', 'N', M, NRHS, N, A, LDA,
+ $ WORK( LW2+1), LW1, B, LDB, WORK( 1 ), LW2,
+ $ INFO )
+*
+ SCLLEN = M
+*
+ END IF
+*
+ ELSE
+*
+* Compute LQ factorization of A
+*
+ CALL ZGELQ( M, N, A, LDA, WORK(LW2+1), LW1
+ $ , WORK(1), LW2, INFO )
+*
+* workspace at least M, optimally M*NB.
+*
+ IF( .NOT.TRAN ) THEN
+*
+* underdetermined system of equations A * X = B
+*
+* B(1:M,1:NRHS) := inv(L) * B(1:M,1:NRHS)
+*
+ CALL ZTRTRS( 'L', 'N', 'N', M, NRHS,
+ $ A, LDA, B, LDB, INFO )
+*
+ IF( INFO.GT.0 ) THEN
+ RETURN
+ END IF
+*
+* B(M+1:N,1:NRHS) = 0
+*
+ DO 40 J = 1, NRHS
+ DO 30 I = M + 1, N
+ B( I, J ) = CZERO
+ 30 CONTINUE
+ 40 CONTINUE
+*
+* B(1:N,1:NRHS) := Q(1:N,:)**T * B(1:M,1:NRHS)
+*
+ CALL ZGEMLQ( 'L', 'C', N, NRHS, M, A, LDA,
+ $ WORK( LW2+1), LW1, B, LDB, WORK( 1 ), LW2,
+ $ INFO )
+*
+* workspace at least NRHS, optimally NRHS*NB
+*
+ SCLLEN = N
+*
+ ELSE
+*
+* overdetermined system min || A**T * X - B ||
+*
+* B(1:N,1:NRHS) := Q * B(1:N,1:NRHS)
+*
+ CALL ZGEMLQ( 'L', 'N', N, NRHS, M, A, LDA,
+ $ WORK( LW2+1), LW1, B, LDB, WORK( 1 ), LW2,
+ $ INFO )
+*
+* workspace at least NRHS, optimally NRHS*NB
+*
+* B(1:M,1:NRHS) := inv(L**T) * B(1:M,1:NRHS)
+*
+ CALL ZTRTRS( 'L', 'C', 'N', M, NRHS,
+ $ A, LDA, B, LDB, INFO )
+*
+ IF( INFO.GT.0 ) THEN
+ RETURN
+ END IF
+*
+ SCLLEN = M
+*
+ END IF
+*
+ END IF
+*
+* Undo scaling
+*
+ IF( IASCL.EQ.1 ) THEN
+ CALL ZLASCL( 'G', 0, 0, ANRM, SMLNUM, SCLLEN, NRHS, B, LDB,
+ $ INFO )
+ ELSE IF( IASCL.EQ.2 ) THEN
+ CALL ZLASCL( 'G', 0, 0, ANRM, BIGNUM, SCLLEN, NRHS, B, LDB,
+ $ INFO )
+ END IF
+ IF( IBSCL.EQ.1 ) THEN
+ CALL ZLASCL( 'G', 0, 0, SMLNUM, BNRM, SCLLEN, NRHS, B, LDB,
+ $ INFO )
+ ELSE IF( IBSCL.EQ.2 ) THEN
+ CALL ZLASCL( 'G', 0, 0, BIGNUM, BNRM, SCLLEN, NRHS, B, LDB,
+ $ INFO )
+ END IF
+*
+ 50 CONTINUE
+ WORK( 1 ) = DBLE( WSIZEO )
+ WORK( 2 ) = DBLE( WSIZEM )
+ RETURN
+*
+* End of ZGETSLS
+*
+ END
\ No newline at end of file
--- /dev/null
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZLAMSWLQ( SIDE, TRANS, M, N, K, MB, NB, A, LDA, T,
+* $ LDT, C, LDC, WORK, LWORK, INFO )
+*
+*
+* .. Scalar Arguments ..
+* CHARACTER SIDE, TRANS
+* INTEGER INFO, LDA, M, N, K, MB, NB, LDT, LWORK, LDC
+* ..
+* .. Array Arguments ..
+* COMPLEX*16 A( LDA, * ), WORK( * ), C(LDC, * ),
+* $ T( LDT, * )
+*> \par Purpose:
+* =============
+*>
+*> \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
+*> factorization (ZLASWLQ)
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] SIDE
+*> SIDE is CHARACTER*1
+*> = 'L': apply Q or Q**T from the Left;
+*> = 'R': apply Q or Q**T from the Right.
+*>
+*> \param[in] TRANS
+*> TRANS is CHARACTER*1
+*> = 'N': No transpose, apply Q;
+*> = 'T': Transpose, apply Q**T.
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows of the matrix A. M >=0.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of columns of the matrix C. N >= M.
+*> \endverbatim
+*>
+*> \param[in] K
+*> \verbatim
+*> K is INTEGER
+*> The number of elementary reflectors whose product defines
+*> the matrix Q.
+*> M >= K >= 0;
+*>
+*> \endverbatim
+*> \param[in] MB
+*> \verbatim
+*> MB is INTEGER
+*> 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.
+*> NB > M.
+*> \endverbatim
+*>
+*> \param[in] NB
+*> \verbatim
+*> NB is INTEGER
+*> The block size to be used in the blocked QR.
+*> MB > M.
+*>
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is COMPLEX*16 array, dimension (LDA,K)
+*> The i-th row must contain the vector which defines the blocked
+*> elementary reflector H(i), for i = 1,2,...,k, as returned by
+*> DLASWLQ in the first k rows of its array argument A.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A.
+*> If SIDE = 'L', LDA >= max(1,M);
+*> if SIDE = 'R', LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in] T
+*> \verbatim
+*> 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
+*> for further details.
+*> \endverbatim
+*>
+*> \param[in] LDT
+*> \verbatim
+*> LDT is INTEGER
+*> The leading dimension of the array T. LDT >= MB.
+*> \endverbatim
+*>
+*> \param[in,out] C
+*> C is COMPLEX*16 array, dimension (LDC,N)
+*> On entry, the M-by-N matrix C.
+*> On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.
+*> \param[in] LDC
+*> LDC is INTEGER
+*> The leading dimension of the array C. LDC >= max(1,M).
+*>
+*> \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,NB) * MB;
+*> if SIDE = 'R', LWORK >= max(1,M) * MB.
+*> If LWORK = -1, then a workspace query is assumed; the routine
+*> only calculates the optimal size of the WORK array, returns
+*> this value as the first entry of the WORK array, and no error
+*> message related to LWORK is issued by XERBLA.
+*>
+*> \endverbatim
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> < 0: if INFO = -i, the i-th argument had an illegal value
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*> Short-Wide LQ (SWLQ) performs LQ by a sequence of orthogonal transformations,
+*> representing Q as a product of other orthogonal matrices
+*> Q = Q(1) * Q(2) * . . . * Q(k)
+*> where each Q(i) zeros out upper diagonal entries of a block of NB rows of A:
+*> Q(1) zeros out the upper diagonal entries of rows 1:NB of A
+*> Q(2) zeros out the bottom MB-N rows of rows [1:M,NB+1:2*NB-M] of A
+*> Q(3) zeros out the bottom MB-N rows of rows [1:M,2*NB-M+1:3*NB-2*M] of A
+*> . . .
+*>
+*> Q(1) is computed by GELQT, which represents Q(1) by Householder vectors
+*> stored under the diagonal of rows 1:MB of A, and by upper triangular
+*> block reflectors, stored in array T(1:LDT,1:N).
+*> For more information see Further Details in GELQT.
+*>
+*> Q(i) for i>1 is computed by TPLQT, which represents Q(i) by Householder vectors
+*> stored in columns [(i-1)*(NB-M)+M+1:i*(NB-M)+M] of A, and by upper triangular
+*> 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].
+*>
+*> [1] “Communication-Optimal Parallel and Sequential QR and LU Factorizations,”
+*> J. Demmel, L. Grigori, M. Hoemmen, J. Langou,
+*> SIAM J. Sci. Comput, vol. 34, no. 1, 2012
+*> \endverbatim
+*>
+* =====================================================================
+ 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) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2013
+*
+* .. Scalar Arguments ..
+ CHARACTER SIDE, TRANS
+ INTEGER INFO, LDA, M, N, K, MB, NB, LDT, LWORK, LDC, LW
+* ..
+* .. Array Arguments ..
+ COMPLEX*16 A( LDA, * ), WORK( * ), C(LDC, * ),
+ $ T( LDT, * )
+* ..
+*
+* =====================================================================
+*
+* ..
+* .. Local Scalars ..
+ LOGICAL LEFT, RIGHT, TRAN, NOTRAN, LQUERY
+ INTEGER I, II, KK, CTR
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* .. External Subroutines ..
+ EXTERNAL ZTPMLQT, ZGEMLQT, XERBLA
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ LQUERY = LWORK.LT.0
+ NOTRAN = LSAME( TRANS, 'N' )
+ TRAN = LSAME( TRANS, 'C' )
+ LEFT = LSAME( SIDE, 'L' )
+ RIGHT = LSAME( SIDE, 'R' )
+ IF (LEFT) THEN
+ LW = N * MB
+ ELSE
+ LW = M * MB
+ END IF
+*
+ INFO = 0
+ IF( .NOT.LEFT .AND. .NOT.RIGHT ) THEN
+ INFO = -1
+ ELSE IF( .NOT.TRAN .AND. .NOT.NOTRAN ) THEN
+ INFO = -2
+ ELSE IF( M.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( K.LT.0 ) THEN
+ INFO = -5
+ ELSE IF( LDA.LT.MAX( 1, K ) ) THEN
+ INFO = -9
+ ELSE IF( LDT.LT.MAX( 1, MB) ) THEN
+ INFO = -11
+ ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
+ INFO = -13
+ ELSE IF(( LWORK.LT.MAX(1,LW)).AND.(.NOT.LQUERY)) THEN
+ INFO = -15
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'ZLAMSWLQ', -INFO )
+ WORK(1) = LW
+ RETURN
+ ELSE IF (LQUERY) THEN
+ WORK(1) = LW
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( MIN(M,N,K).EQ.0 ) THEN
+ RETURN
+ 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)
+ RETURN
+ END IF
+*
+ IF(LEFT.AND.TRAN) THEN
+*
+* Multiply Q to the last block of C
+*
+ KK = MOD((M-K),(NB-K))
+ CTR = (M-K)/(NB-K)
+*
+ IF (KK.GT.0) THEN
+ II=M-KK+1
+ CALL ZTPMLQT('L','C',KK , N, K, 0, MB, A(1,II), LDA,
+ $ T(1,CTR*K+1), LDT, C(1,1), LDC,
+ $ C(II,1), LDC, WORK, INFO )
+ ELSE
+ II=M+1
+ END IF
+*
+ DO I=II-(NB-K),NB+1,-(NB-K)
+*
+* Multiply Q to the current block of C (1:M,I:I+NB)
+*
+ CTR = CTR - 1
+ CALL ZTPMLQT('L','C',NB-K , N, K, 0,MB, A(1,I), 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:M,1:NB)
+*
+ CALL ZGEMLQT('L','C',NB , N, K, MB, A(1,1), LDA, T
+ $ ,LDT ,C(1,1), LDC, WORK, INFO )
+*
+ ELSE IF (LEFT.AND.NOTRAN) THEN
+*
+* Multiply Q to the first block of C
+*
+ KK = MOD((M-K),(NB-K))
+ II=M-KK+1
+ CTR = 1
+ CALL ZGEMLQT('L','N',NB , N, K, MB, A(1,1), LDA, T
+ $ ,LDT ,C(1,1), LDC, WORK, INFO )
+*
+ DO I=NB+1,II-NB+K,(NB-K)
+*
+* Multiply Q to the current block of C (I:I+NB,1:N)
+*
+ CALL ZTPMLQT('L','N',NB-K , N, K, 0,MB, A(1,I), LDA,
+ $ T(1, CTR * K + 1), LDT, C(1,1), LDC,
+ $ C(I,1), LDC, WORK, INFO )
+ CTR = CTR + 1
+*
+ END DO
+ IF(II.LE.M) THEN
+*
+* Multiply Q to the last block of C
+*
+ CALL ZTPMLQT('L','N',KK , N, K, 0, MB, A(1,II), LDA,
+ $ T(1, CTR * K + 1), LDT, C(1,1), LDC,
+ $ C(II,1), LDC, WORK, INFO )
+*
+ END IF
+*
+ ELSE IF(RIGHT.AND.NOTRAN) THEN
+*
+* Multiply Q to the last block of C
+*
+ KK = MOD((N-K),(NB-K))
+ CTR = (N-K)/(NB-K)
+ IF (KK.GT.0) THEN
+ II=N-KK+1
+ CALL ZTPMLQT('R','N',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 )
+ ELSE
+ II=N+1
+ END IF
+*
+ DO I=II-(NB-K),NB+1,-(NB-K)
+*
+* Multiply Q to the current block of C (1:M,I:I+MB)
+*
+ CTR = CTR - 1
+ CALL ZTPMLQT('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 )
+
+ END DO
+*
+* Multiply Q to the first block of C (1:M,1:MB)
+*
+ CALL ZGEMLQT('R','N',M , NB, K, MB, A(1,1), LDA, T
+ $ ,LDT ,C(1,1), LDC, WORK, INFO )
+*
+ ELSE IF (RIGHT.AND.TRAN) THEN
+*
+* Multiply Q to the first block of C
+*
+ KK = MOD((N-K),(NB-K))
+ II=N-KK+1
+ CALL ZGEMLQT('R','C',M , NB, K, MB, A(1,1), LDA, T
+ $ ,LDT ,C(1,1), LDC, WORK, INFO )
+ CTR = 1
+*
+ DO I=NB+1,II-NB+K,(NB-K)
+*
+* Multiply Q to the current block of C (1:M,I:I+MB)
+*
+ CALL ZTPMLQT('R','C',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 )
+ CTR = CTR + 1
+*
+ END DO
+ 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 IF
+*
+ END IF
+*
+ WORK(1) = LW
+ RETURN
+*
+* End of ZLAMSWLQ
+*
+ END
\ No newline at end of file
--- /dev/null
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZLAMTSQR( SIDE, TRANS, M, N, K, MB, NB, A, LDA, T,
+* $ LDT, C, LDC, WORK, LWORK, INFO )
+*
+*
+* .. Scalar Arguments ..
+* CHARACTER SIDE, TRANS
+* INTEGER INFO, LDA, M, N, K, MB, NB, LDT, LWORK, LDC
+* ..
+* .. Array Arguments ..
+* COMPLEX*16 A( LDA, * ), WORK( * ), C(LDC, * ),
+* $ T( LDT, * )
+*> \par Purpose:
+* =============
+*>
+*> \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
+*> QR factorization (ZLATSQR)
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] SIDE
+*> SIDE is CHARACTER*1
+*> = 'L': apply Q or Q**T from the Left;
+*> = 'R': apply Q or Q**T from the Right.
+*>
+*> \param[in] TRANS
+*> TRANS is CHARACTER*1
+*> = 'N': No transpose, apply Q;
+*> = 'C': Conjugate Transpose, apply Q**C.
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows of the matrix A. M >=0.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of columns of the matrix C. M >= N >= 0.
+*> \endverbatim
+*>
+*> \param[in] K
+*> \verbatim
+*> K is INTEGER
+*> The number of elementary reflectors whose product defines
+*> the matrix Q.
+*> N >= K >= 0;
+*>
+*> \endverbatim
+*>
+*> \param[in] MB
+*> \verbatim
+*> MB is INTEGER
+*> 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.
+*> 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
+*> its array argument A.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A.
+*> If SIDE = 'L', LDA >= max(1,M);
+*> if SIDE = 'R', LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in] T
+*> \verbatim
+*> 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
+*> for further details.
+*> \endverbatim
+*>
+*> \param[in] LDT
+*> \verbatim
+*> LDT is INTEGER
+*> The leading dimension of the array T. LDT >= NB.
+*> \endverbatim
+*>
+*> \param[in,out] C
+*> C is COMPLEX*16 array, dimension (LDC,N)
+*> On entry, the M-by-N matrix C.
+*> On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.
+*> \param[in] LDC
+*> LDC is INTEGER
+*> The leading dimension of the array C. LDC >= max(1,M).
+*>
+*> \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
+*> only calculates the optimal size of the WORK array, returns
+*> this value as the first entry of the WORK array, and no error
+*> message related to LWORK is issued by XERBLA.
+*>
+*> \endverbatim
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> < 0: if INFO = -i, the i-th argument had an illegal value
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*> Tall-Skinny QR (TSQR) performs QR by a sequence of orthogonal transformations,
+*> representing Q as a product of other orthogonal matrices
+*> Q = Q(1) * Q(2) * . . . * Q(k)
+*> where each Q(i) zeros out subdiagonal entries of a block of MB rows of A:
+*> Q(1) zeros out the subdiagonal entries of rows 1:MB of A
+*> Q(2) zeros out the bottom MB-N rows of rows [1:N,MB+1:2*MB-N] of A
+*> Q(3) zeros out the bottom MB-N rows of rows [1:N,2*MB-N+1:3*MB-2*N] of A
+*> . . .
+*>
+*> Q(1) is computed by GEQRT, which represents Q(1) by Householder vectors
+*> stored under the diagonal of rows 1:MB of A, and by upper triangular
+*> block reflectors, stored in array T(1:LDT,1:N).
+*> For more information see Further Details in GEQRT.
+*>
+*> Q(i) for i>1 is computed by TPQRT, which represents Q(i) by Householder vectors
+*> stored in rows [(i-1)*(MB-N)+N+1:i*(MB-N)+N] of A, and by upper triangular
+*> 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].
+*>
+*> [1] “Communication-Optimal Parallel and Sequential QR and LU Factorizations,”
+*> J. Demmel, L. Grigori, M. Hoemmen, J. Langou,
+*> SIAM J. Sci. Comput, vol. 34, no. 1, 2012
+*> \endverbatim
+*>
+* =====================================================================
+ 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) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2013
+*
+* .. Scalar Arguments ..
+ CHARACTER SIDE, TRANS
+ INTEGER INFO, LDA, M, N, K, MB, NB, LDT, LWORK, LDC
+* ..
+* .. Array Arguments ..
+ COMPLEX*16 A( LDA, * ), WORK( * ), C(LDC, * ),
+ $ T( LDT, * )
+* ..
+*
+* =====================================================================
+*
+* ..
+* .. Local Scalars ..
+ LOGICAL LEFT, RIGHT, TRAN, NOTRAN, LQUERY
+ INTEGER I, II, KK, LW, CTR
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* .. External Subroutines ..
+ EXTERNAL ZGEMQRT, ZTPMQRT, XERBLA
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ LQUERY = LWORK.LT.0
+ NOTRAN = LSAME( TRANS, 'N' )
+ TRAN = LSAME( TRANS, 'C' )
+ LEFT = LSAME( SIDE, 'L' )
+ RIGHT = LSAME( SIDE, 'R' )
+ IF (LEFT) THEN
+ LW = N * NB
+ ELSE
+ LW = M * NB
+ END IF
+*
+ INFO = 0
+ IF( .NOT.LEFT .AND. .NOT.RIGHT ) THEN
+ INFO = -1
+ ELSE IF( .NOT.TRAN .AND. .NOT.NOTRAN ) THEN
+ INFO = -2
+ ELSE IF( M.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( K.LT.0 ) THEN
+ INFO = -5
+ ELSE IF( LDA.LT.MAX( 1, K ) ) THEN
+ INFO = -9
+ ELSE IF( LDT.LT.MAX( 1, NB) ) THEN
+ INFO = -11
+ ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
+ INFO = -13
+ ELSE IF(( LWORK.LT.MAX(1,LW)).AND.(.NOT.LQUERY)) THEN
+ INFO = -15
+ 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
+ ELSE IF (LQUERY) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( MIN(M,N,K).EQ.0 ) THEN
+ 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)
+ RETURN
+ END IF
+*
+ IF(LEFT.AND.NOTRAN) THEN
+*
+* Multiply Q to the last block of C
+*
+ KK = MOD((M-K),(MB-K))
+ CTR = (M-K)/(MB-K)
+ IF (KK.GT.0) THEN
+ II=M-KK+1
+ CALL ZTPMQRT('L','N',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 )
+ ELSE
+ II=M+1
+ END IF
+*
+ DO I=II-(MB-K),MB+1,-(MB-K)
+*
+* Multiply Q to the current block of C (I:I+MB,1:N)
+*
+ CTR = CTR - 1
+ CALL ZTPMQRT('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)
+*
+ CALL ZGEMQRT('L','N',MB , N, K, NB, A(1,1), LDA, T
+ $ ,LDT ,C(1,1), LDC, WORK, INFO )
+*
+ ELSE IF (LEFT.AND.TRAN) THEN
+*
+* Multiply Q to the first block of C
+*
+ KK = MOD((M-K),(MB-K))
+ II=M-KK+1
+ CALL ZGEMQRT('L','C',MB , N, K, NB, A(1,1), LDA, T
+ $ ,LDT ,C(1,1), LDC, WORK, INFO )
+ CTR = 1
+*
+ DO I=MB+1,II-MB+K,(MB-K)
+*
+* Multiply Q to the current block of C (I:I+MB,1:N)
+*
+ CALL ZTPMQRT('L','C',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 )
+ CTR = CTR + 1
+*
+ END DO
+ 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
+*
+ ELSE IF(RIGHT.AND.TRAN) THEN
+*
+* Multiply Q to the last block of C
+*
+ KK = MOD((N-K),(MB-K))
+ CTR = (N-K)/(MB-K)
+ IF (KK.GT.0) THEN
+ II=N-KK+1
+ CALL ZTPMQRT('R','C',M , KK, K, 0, NB, A(II,1), LDA,
+ $ T(1,CTR * K + 1), LDT, C(1,1), LDC,
+ $ C(1,II), LDC, WORK, INFO )
+ ELSE
+ II=N+1
+ END IF
+*
+ DO I=II-(MB-K),MB+1,-(MB-K)
+ CTR = CTR - 1
+*
+* Multiply Q to the current block of C (1:M,I:I+MB)
+*
+ CALL ZTPMQRT('R','C',M , MB-K, K, 0,NB, A(I,1), LDA,
+ $ T(1, CTR * K + 1), LDT, C(1,1), LDC,
+ $ C(1,I), LDC, WORK, INFO )
+
+ END DO
+*
+* Multiply Q to the first block of C (1:M,1:MB)
+*
+ CALL ZGEMQRT('R','C',M , MB, K, NB, A(1,1), LDA, T
+ $ ,LDT ,C(1,1), LDC, WORK, INFO )
+*
+ ELSE IF (RIGHT.AND.NOTRAN) THEN
+*
+* Multiply Q to the first block of C
+*
+ KK = MOD((N-K),(MB-K))
+ II=N-KK+1
+ CALL ZGEMQRT('R','N', M, MB , K, NB, A(1,1), LDA, T
+ $ ,LDT ,C(1,1), LDC, WORK, INFO )
+ CTR = 1
+*
+ DO I=MB+1,II-MB+K,(MB-K)
+*
+* Multiply Q to the current block of C (1:M,I:I+MB)
+*
+ CALL ZTPMQRT('R','N', M, MB-K, K, 0,NB, A(I,1), LDA,
+ $ T(1, CTR * K + 1),LDT, C(1,1), LDC,
+ $ C(1,I), LDC, WORK, INFO )
+ CTR = CTR + 1
+*
+ END DO
+ IF(II.LE.N) THEN
+*
+* Multiply Q to the last block of C
+*
+ CALL ZTPMQRT('R','N', M, KK , K, 0,NB, A(II,1), LDA,
+ $ T(1,CTR * K + 1),LDT, C(1,1), LDC,
+ $ C(1,II), LDC, WORK, INFO )
+*
+ END IF
+*
+ END IF
+*
+ WORK(1) = LW
+ RETURN
+*
+* End of ZLAMTSQR
+*
+ END
\ No newline at end of file
--- /dev/null
+*
+* 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
+*> M-by-N matrix A, where N >= M:
+*> A = L * Q
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows of the matrix A. M >= 0.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of columns of the matrix A. N >= M >= 0.
+*> \endverbatim
+*>
+*> \param[in] MB
+*> \verbatim
+*> MB is INTEGER
+*> 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.
+*> NB > M.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \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
+*> of blocked V (see Further Details).
+*>
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,M).
+*> \endverbatim
+*>
+*> \param[out] T
+*> \verbatim
+*> 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.
+*> See Further Details below.
+*> \endverbatim
+*>
+*> \param[in] LDT
+*> \verbatim
+*> LDT is INTEGER
+*> The leading dimension of the array T. LDT >= MB.
+*> \endverbatim
+*>
+*>
+*> \param[out] WORK
+*> \verbatim
+*> (workspace) COMPLEX*16 array, dimension (MAX(1,LWORK))
+*>
+*> \endverbatim
+*> \param[in] LWORK
+*> \verbatim
+*> The dimension of the array WORK. LWORK >= MB*M.
+*> If LWORK = -1, then a workspace query is assumed; the routine
+*> only calculates the optimal size of the WORK array, returns
+*> this value as the first entry of the WORK array, and no error
+*> message related to LWORK is issued by XERBLA.
+*>
+*> \endverbatim
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> < 0: if INFO = -i, the i-th argument had an illegal value
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*> Short-Wide LQ (SWLQ) performs LQ by a sequence of orthogonal transformations,
+*> representing Q as a product of other orthogonal matrices
+*> Q = Q(1) * Q(2) * . . . * Q(k)
+*> where each Q(i) zeros out upper diagonal entries of a block of NB rows of A:
+*> Q(1) zeros out the upper diagonal entries of rows 1:NB of A
+*> Q(2) zeros out the bottom MB-N rows of rows [1:M,NB+1:2*NB-M] of A
+*> Q(3) zeros out the bottom MB-N rows of rows [1:M,2*NB-M+1:3*NB-2*M] of A
+*> . . .
+*>
+*> Q(1) is computed by GELQT, which represents Q(1) by Householder vectors
+*> stored under the diagonal of rows 1:MB of A, and by upper triangular
+*> block reflectors, stored in array T(1:LDT,1:N).
+*> For more information see Further Details in GELQT.
+*>
+*> Q(i) for i>1 is computed by TPLQT, which represents Q(i) by Householder vectors
+*> stored in columns [(i-1)*(NB-M)+M+1:i*(NB-M)+M] of A, and by upper triangular
+*> 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].
+*>
+*> [1] “Communication-Optimal Parallel and Sequential QR and LU Factorizations,”
+*> J. Demmel, L. Grigori, M. Hoemmen, J. Langou,
+*> SIAM J. Sci. Comput, vol. 34, no. 1, 2012
+*> \endverbatim
+*>
+* =====================================================================
+ SUBROUTINE ZLASWLQ( M, N, MB, NB, A, LDA, T, LDT, WORK, LWORK,
+ $ INFO)
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd. --
+* November 2013
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, M, N, MB, NB, LWORK, LDT
+* ..
+* .. Array Arguments ..
+ COMPLEX*16 A( LDA, * ), WORK( * ), T( LDT, *)
+* ..
+*
+* =====================================================================
+*
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY
+ INTEGER I, II, KK, CTR
+* ..
+* .. EXTERNAL FUNCTIONS ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* .. EXTERNAL SUBROUTINES ..
+ EXTERNAL ZGELQT, ZTPLQT, XERBLA
+* .. INTRINSIC FUNCTIONS ..
+ INTRINSIC MAX, MIN, MOD
+* ..
+* .. EXECUTABLE STATEMENTS ..
+*
+* TEST THE INPUT ARGUMENTS
+*
+ INFO = 0
+*
+ LQUERY = ( LWORK.EQ.-1 )
+*
+ IF( M.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 .OR. N.LT.M ) THEN
+ INFO = -2
+ ELSE IF( MB.LT.1 .OR. ( MB.GT.M .AND. M.GT.0 )) THEN
+ INFO = -3
+ ELSE IF( NB.LE.M ) THEN
+ INFO = -4
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -5
+ 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
+ WORK(1) = MB*M
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'ZLASWLQ', -INFO )
+ RETURN
+ ELSE IF (LQUERY) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( MIN(M,N).EQ.0 ) THEN
+ RETURN
+ END IF
+*
+* The LQ Decomposition
+*
+ 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
+*
+ KK = MOD((N-M),(NB-M))
+ II=N-KK+1
+*
+* Compute the LQ factorization of the first block A(1:M,1:NB)
+*
+ CALL ZGELQT( M, NB, MB, A(1,1), LDA, T, LDT, WORK, INFO)
+ 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 ),
+ $ LDA, T(1, CTR * M + 1),
+ $ LDT, WORK, INFO )
+ CTR = CTR + 1
+ END DO
+*
+* Compute the QR factorization of the last block A(1:M,II:N)
+*
+ IF (II.LE.N) THEN
+ CALL ZTPLQT( M, KK, 0, MB, A(1,1), LDA, A( 1, II ),
+ $ LDA, T(1, CTR * M + 1), LDT,
+ $ WORK, INFO )
+ END IF
+*
+ WORK( 1 ) = M * MB
+ RETURN
+*
+* End of ZLASWLQ
+*
+ END
\ No newline at end of file
--- /dev/null
+*
+* Definition:
+* ===========
+*
+* 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
+*> an M-by-N matrix A, where M >= N:
+*> A = Q * R .
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows of the matrix A. M >= 0.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of columns of the matrix A. M >= N >= 0.
+*> \endverbatim
+*>
+*> \param[in] MB
+*> \verbatim
+*> MB is INTEGER
+*> 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.
+*> N >= NB >= 1.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \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
+*> of blocked V (see Further Details).
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,M).
+*> \endverbatim
+*>
+*> \param[out] T
+*> \verbatim
+*> 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.
+*> See Further Details below.
+*> \endverbatim
+*>
+*> \param[in] LDT
+*> \verbatim
+*> LDT is INTEGER
+*> The leading dimension of the array T. LDT >= NB.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> (workspace) COMPLEX*16 array, dimension (MAX(1,LWORK))
+*> \endverbatim
+*>
+*> \param[in] LWORK
+*> \verbatim
+*> The dimension of the array WORK. LWORK >= NB*N.
+*> If LWORK = -1, then a workspace query is assumed; the routine
+*> only calculates the optimal size of the WORK array, returns
+*> this value as the first entry of the WORK array, and no error
+*> message related to LWORK is issued by XERBLA.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> < 0: if INFO = -i, the i-th argument had an illegal value
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*> Tall-Skinny QR (TSQR) performs QR by a sequence of orthogonal transformations,
+*> representing Q as a product of other orthogonal matrices
+*> Q = Q(1) * Q(2) * . . . * Q(k)
+*> where each Q(i) zeros out subdiagonal entries of a block of MB rows of A:
+*> Q(1) zeros out the subdiagonal entries of rows 1:MB of A
+*> Q(2) zeros out the bottom MB-N rows of rows [1:N,MB+1:2*MB-N] of A
+*> Q(3) zeros out the bottom MB-N rows of rows [1:N,2*MB-N+1:3*MB-2*N] of A
+*> . . .
+*>
+*> Q(1) is computed by GEQRT, which represents Q(1) by Householder vectors
+*> stored under the diagonal of rows 1:MB of A, and by upper triangular
+*> block reflectors, stored in array T(1:LDT,1:N).
+*> For more information see Further Details in GEQRT.
+*>
+*> Q(i) for i>1 is computed by TPQRT, which represents Q(i) by Householder vectors
+*> stored in rows [(i-1)*(MB-N)+N+1:i*(MB-N)+N] of A, and by upper triangular
+*> 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].
+*>
+*> [1] “Communication-Optimal Parallel and Sequential QR and LU Factorizations,”
+*> J. Demmel, L. Grigori, M. Hoemmen, J. Langou,
+*> SIAM J. Sci. Comput, vol. 34, no. 1, 2012
+*> \endverbatim
+*>
+* =====================================================================
+ SUBROUTINE ZLATSQR( M, N, MB, NB, A, LDA, T, LDT, WORK,
+ $ LWORK, INFO)
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd. --
+* November 2013
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, M, N, MB, NB, LDT, LWORK
+* ..
+* .. Array Arguments ..
+ COMPLEX*16 A( LDA, * ), WORK( * ), T(LDT, *)
+* ..
+*
+* =====================================================================
+*
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY
+ INTEGER I, II, KK, CTR
+* ..
+* .. EXTERNAL FUNCTIONS ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* .. EXTERNAL SUBROUTINES ..
+ EXTERNAL ZGEQRT, ZTPQRT, XERBLA
+* .. INTRINSIC FUNCTIONS ..
+ INTRINSIC MAX, MIN, MOD
+* ..
+* .. EXECUTABLE STATEMENTS ..
+*
+* TEST THE INPUT ARGUMENTS
+*
+ INFO = 0
+*
+ LQUERY = ( LWORK.EQ.-1 )
+*
+ IF( M.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 .OR. M.LT.N ) THEN
+ INFO = -2
+ ELSE IF( MB.LE.N ) THEN
+ 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
+ INFO = -5
+ ELSE IF( LDT.LT.NB ) THEN
+ INFO = -8
+ ELSE IF( LWORK.LT.(N*NB) .AND. (.NOT.LQUERY) ) THEN
+ INFO = -10
+ END IF
+ IF( INFO.EQ.0) THEN
+ WORK(1) = NB*N
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'ZLATSQR', -INFO )
+ RETURN
+ ELSE IF (LQUERY) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( MIN(M,N).EQ.0 ) THEN
+ RETURN
+ END IF
+*
+* The QR Decomposition
+*
+ IF ((MB.LE.N).OR.(MB.GE.M)) THEN
+ CALL ZGEQRT( M, N, NB, A, LDA, T, LDT, WORK, INFO)
+ RETURN
+ END IF
+ KK = MOD((M-N),(MB-N))
+ II=M-KK+1
+*
+* Compute the QR factorization of the first block A(1:MB,1:N)
+*
+ CALL ZGEQRT( MB, N, NB, A(1,1), LDA, T, LDT, WORK, INFO )
+ 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,
+ $ T(1, CTR * N + 1),
+ $ LDT, WORK, INFO )
+ CTR = CTR + 1
+ END DO
+*
+* Compute the QR factorization of the last block A(II:M,1:N)
+*
+ IF (II.LE.M) THEN
+ CALL ZTPQRT( KK, N, 0, NB, A(1,1), LDA, A( II, 1 ), LDA,
+ $ T(1,CTR * N + 1), LDT,
+ $ WORK, INFO )
+ END IF
+*
+ work( 1 ) = N*NB
+ RETURN
+*
+* End of ZLATSQR
+*
+ END
\ No newline at end of file
--- /dev/null
+*> \brief \b ZTPLQT
+*
+* =========== DOCUMENTATION ===========
+*
+* 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">
+*> [TXT]</a>
+*> \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
+*> WY representation for Q.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows of the matrix B, and the order of the
+*> triangular matrix A.
+*> M >= 0.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of columns of the matrix B.
+*> N >= 0.
+*> \endverbatim
+*>
+*> \param[in] L
+*> \verbatim
+*> L is INTEGER
+*> The number of rows of the lower trapezoidal part of B.
+*> MIN(M,N) >= L >= 0. See Further Details.
+*> \endverbatim
+*>
+*> \param[in] MB
+*> \verbatim
+*> MB is INTEGER
+*> The block size to be used in the blocked QR. M >= MB >= 1.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is COMPLEX*16 array, dimension (LDA,N)
+*> On entry, the lower triangular N-by-N matrix A.
+*> On exit, the elements on and below the diagonal of the array
+*> contain the lower triangular matrix L.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in,out] B
+*> \verbatim
+*> B is COMPLEX*16 array, dimension (LDB,N)
+*> 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
+*>
+*> \param[in] LDB
+*> \verbatim
+*> LDB is INTEGER
+*> The leading dimension of the array B. LDB >= max(1,M).
+*> \endverbatim
+*>
+*> \param[out] T
+*> \verbatim
+*> T is COMPLEX*16 array, dimension (LDT,N)
+*> 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
+*> The leading dimension of the array T. LDT >= MB.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is COMPLEX*16 array, dimension (MB*M)
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> < 0: if INFO = -i, the i-th argument had an illegal value
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2013
+*
+*> \ingroup doubleOTHERcomputational
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*>
+*> 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 ]
+*> [ 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.
+*>
+*> 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 ]
+*> [ A ] <- lower triangular N-by-N
+*> [ B ] <- M-by-N pentagonal
+*>
+*> so that W can be represented as
+*> [ 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 ]
+*> [ 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 number of blocks is B = ceiling(M/MB), where each
+*> 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
+*> for the last block) T's are stored in the MB-by-N matrix T as
+*>
+*> T = [T1 T2 ... TB].
+*> \endverbatim
+*>
+* =====================================================================
+ SUBROUTINE ZTPLQT( M, N, L, MB, A, LDA, B, LDB, T, LDT, WORK,
+ $ INFO )
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2013
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, LDB, LDT, N, M, L, MB
+* ..
+* .. Array Arguments ..
+ COMPLEX*16 A( LDA, * ), B( LDB, * ), T( LDT, * ), WORK( * )
+* ..
+*
+* =====================================================================
+*
+* ..
+* .. Local Scalars ..
+ INTEGER I, IB, LB, NB, IINFO
+* ..
+* .. External Subroutines ..
+ EXTERNAL ZTPLQT2, ZTPRFB, XERBLA
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+ IF( M.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( L.LT.0 .OR. (L.GT.MIN(M,N) .AND. MIN(M,N).GE.0)) THEN
+ INFO = -3
+ ELSE IF( MB.LT.1 .OR. (MB.GT.M .AND. M.GT.0)) THEN
+ INFO = -4
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -6
+ ELSE IF( LDB.LT.MAX( 1, M ) ) THEN
+ INFO = -8
+ ELSE IF( LDT.LT.MB ) THEN
+ INFO = -10
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'ZTPLQT', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ 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 )
+ NB = MIN( N-L+I+IB-1, N )
+ IF( I.GE.L ) THEN
+ LB = 0
+ ELSE
+ LB = NB-N+L-I+1
+ END IF
+*
+ 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,
+ $ WORK, M-I-IB+1)
+ END IF
+ END DO
+ RETURN
+*
+* End of ZTPLQT
+*
+ END
--- /dev/null
+*> \brief \b ZTPLQT2 computes a LQ factorization of a real or complex "triangular-pentagonal" matrix, which is composed of a triangular block and a pentagonal block, using the compact WY representation for Q.
+*
+* =========== DOCUMENTATION ===========
+*
+* 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">
+*> [TXT]</a>
+*> \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,
+*> using the compact WY representation for Q.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The total number of rows of the matrix B.
+*> M >= 0.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of columns of the matrix B, and the order of
+*> the triangular matrix A.
+*> N >= 0.
+*> \endverbatim
+*>
+*> \param[in] L
+*> \verbatim
+*> L is INTEGER
+*> The number of rows of the lower trapezoidal part of B.
+*> MIN(M,N) >= L >= 0. See Further Details.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is COMPLEX*16 array, dimension (LDA,N)
+*> On entry, the lower triangular M-by-M matrix A.
+*> On exit, the elements on and below the diagonal of the array
+*> contain the lower triangular matrix L.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in,out] B
+*> \verbatim
+*> B is COMPLEX*16 array, dimension (LDB,N)
+*> 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
+*>
+*> \param[in] LDB
+*> \verbatim
+*> LDB is INTEGER
+*> The leading dimension of the array B. LDB >= max(1,M).
+*> \endverbatim
+*>
+*> \param[out] T
+*> \verbatim
+*> T is COMPLEX*16 array, dimension (LDT,M)
+*> The N-by-N upper triangular factor T of the block reflector.
+*> See Further Details.
+*> \endverbatim
+*>
+*> \param[in] LDT
+*> \verbatim
+*> LDT is INTEGER
+*> The leading dimension of the array T. LDT >= max(1,M)
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> < 0: if INFO = -i, the i-th argument had an illegal value
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date September 2012
+*
+*> \ingroup doubleOTHERcomputational
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*>
+*> 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
+*> upper trapezoidal matrix B2:
+*>
+*> B = [ B1 ][ B2 ]
+*> [ B1 ] <- M-by-(N-L) rectangular
+*> [ 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.
+*>
+*> 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 ]
+*> [ A ] <- lower triangular N-by-N
+*> [ B ] <- M-by-N pentagonal
+*>
+*> so that W can be represented as
+*>
+*> 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,
+*>
+*> 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 (M+N)-by-(M+N) block reflector H is then given by
+*>
+*> H = I - W**T * T * W
+*>
+*> where W^H is the conjugate transpose of W and T is the upper triangular
+*> factor of the block reflector.
+*> \endverbatim
+*>
+* =====================================================================
+ SUBROUTINE ZTPLQT2( M, N, L, A, LDA, B, LDB, T, LDT, INFO )
+*
+* -- LAPACK computational routine (version 3.4.2) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* September 2012
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, LDB, LDT, N, M, L
+* ..
+* .. Array Arguments ..
+ COMPLEX*16 A( LDA, * ), B( LDB, * ), T( LDT, * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ COMPLEX*16 ONE, ZERO
+ PARAMETER( ZERO = ( 0.0D+0, 0.0D+0 ),ONE = ( 1.0D+0, 0.0D+0 ) )
+* ..
+* .. Local Scalars ..
+ INTEGER I, J, P, MP, NP
+ COMPLEX*16 ALPHA
+* ..
+* .. External Subroutines ..
+ EXTERNAL ZLARFG, ZGEMV, ZGERC, ZTRMV, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+ IF( M.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( L.LT.0 .OR. L.GT.MIN(M,N) ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -5
+ ELSE IF( LDB.LT.MAX( 1, M ) ) THEN
+ INFO = -7
+ ELSE IF( LDT.LT.MAX( 1, M ) ) THEN
+ INFO = -9
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'ZTPLQT2', -INFO )
+ RETURN
+ END IF
+*
+* 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,:)
+*
+ P = N-L+MIN( L, I )
+ CALL ZLARFG( P+1, A( I, I ), B( I, 1 ), LDB, T( 1, I ) )
+ T(1,I)=CONJG(T(1,I))
+ IF( I.LT.M ) THEN
+ DO J = 1, P
+ B( I, J ) = CONJG(B(I,J))
+ END DO
+*
+* W(M-I:1) := C(I+1:M,I:N) * C(I,I:N) [use W = T(M,:)]
+*
+ 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,
+ $ 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 ))
+ DO J = 1, M-I
+ A( I+J, I ) = A( I+J, I ) + ALPHA*(T( M, J ))
+ END DO
+ CALL ZGERC( M-I, P, (ALPHA), T( M, 1 ), LDT,
+ $ B( I, 1 ), LDB, B( I+1, 1 ), LDB )
+ DO J = 1, P
+ B( I, J ) = CONJG(B(I,J))
+ END DO
+ END IF
+ END DO
+*
+ DO I = 2, M
+*
+* T(I,1:I-1) := C(I:I-1,1:N)**H * (alpha * C(I,I:N))
+*
+ ALPHA = -(T( 1, I ))
+ DO J = 1, I-1
+ T( I, J ) = ZERO
+ END DO
+ P = MIN( I-1, L )
+ NP = MIN( N-L+1, N )
+ MP = MIN( P+1, M )
+ DO J = 1, N-L+P
+ B(I,J)=CONJG(B(I,J))
+ END DO
+*
+* Triangular part of B2
+*
+ DO J = 1, P
+ T( I, J ) = (ALPHA*B( I, N-L+J ))
+ END DO
+ CALL ZTRMV( 'L', 'N', 'N', P, B( 1, NP ), LDB,
+ $ T( I, 1 ), LDT )
+*
+* Rectangular part of B2
+*
+ 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 )
+*
+
+*
+* T(1:I-1,I) := T(1:I-1,1:I-1) * T(I,1:I-1)
+*
+ DO J = 1, I-1
+ T(I,J)=CONJG(T(I,J))
+ END DO
+ CALL ZTRMV( 'L', 'C', 'N', I-1, T, LDT, T( I, 1 ), LDT )
+ DO J = 1, I-1
+ T(I,J)=CONJG(T(I,J))
+ END DO
+ DO J = 1, N-L+P
+ B(I,J)=CONJG(B(I,J))
+ END DO
+*
+* T(I,I) = tau(I)
+*
+ T( I, I ) = T( 1, I )
+ T( 1, I ) = ZERO
+ END DO
+ DO I=1,M
+ DO J= I+1,M
+ T(I,J)=(T(J,I))
+ T(J,I)=ZERO
+ END DO
+ END DO
+
+*
+* End of ZTPLQT2
+*
+ END
--- /dev/null
+*> \brief \b ZTPMLQT
+*
+* =========== DOCUMENTATION ===========
+*
+* 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">
+*> [TXT]</a>
+*> \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, * ),
+* $ T( LDT, * ), WORK( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> 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
+*
+* Arguments:
+* ==========
+*
+*> \param[in] SIDE
+*> \verbatim
+*> SIDE is CHARACTER*1
+*> = 'L': apply Q or Q**C from the Left;
+*> = 'R': apply Q or Q**C from the Right.
+*> \endverbatim
+*>
+*> \param[in] TRANS
+*> \verbatim
+*> TRANS is CHARACTER*1
+*> = 'N': No transpose, apply Q;
+*> = 'C': Transpose, apply Q**C.
+*> \endverbatim
+*>
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows of the matrix B. M >= 0.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of columns of the matrix B. N >= 0.
+*> \endverbatim
+*>
+*> \param[in] K
+*> \verbatim
+*> K is INTEGER
+*> The number of elementary reflectors whose product defines
+*> the matrix Q.
+*> \endverbatim
+*>
+*> \param[in] L
+*> \verbatim
+*> L is INTEGER
+*> The order of the trapezoidal part of V.
+*> K >= L >= 0. See Further Details.
+*> \endverbatim
+*>
+*> \param[in] MB
+*> \verbatim
+*> MB is INTEGER
+*> The block size used for the storage of T. K >= MB >= 1.
+*> This must be the same value of MB used to generate T
+*> in DTPLQT.
+*> \endverbatim
+*>
+*> \param[in] V
+*> \verbatim
+*> V is COMPLEX*16 array, dimension (LDA,K)
+*> The i-th row must contain the vector which defines the
+*> elementary reflector H(i), for i = 1,2,...,k, as returned by
+*> DTPLQT in B. See Further Details.
+*> \endverbatim
+*>
+*> \param[in] LDV
+*> \verbatim
+*> LDV is INTEGER
+*> The leading dimension of the array V.
+*> If SIDE = 'L', LDV >= max(1,M);
+*> if SIDE = 'R', LDV >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in] T
+*> \verbatim
+*> T is COMPLEX*16 array, dimension (LDT,K)
+*> The upper triangular factors of the block reflectors
+*> as returned by DTPLQT, stored as a MB-by-K matrix.
+*> \endverbatim
+*>
+*> \param[in] LDT
+*> \verbatim
+*> LDT is INTEGER
+*> The leading dimension of the array T. LDT >= MB.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is COMPLEX*16 array, dimension
+*> (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
+*> 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.
+*> If SIDE = 'L', LDC >= max(1,K);
+*> If SIDE = 'R', LDC >= max(1,M).
+*> \endverbatim
+*>
+*> \param[in,out] B
+*> \verbatim
+*> B is COMPLEX*16 array, dimension (LDB,N)
+*> On entry, the M-by-N matrix B.
+*> On exit, B 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] LDB
+*> \verbatim
+*> LDB is INTEGER
+*> The leading dimension of the array B.
+*> LDB >= max(1,M).
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is COMPLEX*16 array. The dimension of WORK is
+*> N*MB if SIDE = 'L', or M*MB if SIDE = 'R'.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> < 0: if INFO = -i, the i-th argument had an illegal value
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2015
+*
+*> \ingroup doubleOTHERcomputational
+*
+*> \par Further Details:
+* =====================
+*>
+*> \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
+*> trapezoidal block V2:
+*>
+*> V = [V1] [V2].
+*>
+*>
+*> 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 = '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.
+*>
+*> If TRANS='N' and SIDE='L', C is on exit replaced with Q * C.
+*>
+*> If TRANS='C' and SIDE='L', C is on exit replaced with Q**C * C.
+*>
+*> If TRANS='N' and SIDE='R', C is on exit replaced with C * Q.
+*>
+*> If TRANS='C' and SIDE='R', C is on exit replaced with C * Q**C.
+*> \endverbatim
+*>
+* =====================================================================
+ SUBROUTINE ZTPMLQT( SIDE, TRANS, M, N, K, L, MB, V, LDV, T, LDT,
+ $ A, LDA, B, LDB, WORK, INFO )
+*
+* -- LAPACK computational routine (version 3.6.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2015
+*
+* .. 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, * ),
+ $ T( LDT, * ), WORK( * )
+* ..
+*
+* =====================================================================
+*
+* ..
+* .. Local Scalars ..
+ LOGICAL LEFT, RIGHT, TRAN, NOTRAN
+ INTEGER I, IB, NB, LB, KF, LDAQ
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL XERBLA, ZTPRFB
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* .. Test the input arguments ..
+*
+ INFO = 0
+ LEFT = LSAME( SIDE, 'L' )
+ RIGHT = LSAME( SIDE, 'R' )
+ TRAN = LSAME( TRANS, 'C' )
+ NOTRAN = LSAME( TRANS, 'N' )
+*
+ IF ( LEFT ) THEN
+ LDAQ = MAX( 1, K )
+ ELSE IF ( RIGHT ) THEN
+ LDAQ = MAX( 1, M )
+ END IF
+ IF( .NOT.LEFT .AND. .NOT.RIGHT ) THEN
+ INFO = -1
+ ELSE IF( .NOT.TRAN .AND. .NOT.NOTRAN ) THEN
+ INFO = -2
+ ELSE IF( M.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( K.LT.0 ) THEN
+ INFO = -5
+ ELSE IF( L.LT.0 .OR. L.GT.K ) THEN
+ INFO = -6
+ ELSE IF( MB.LT.1 .OR. (MB.GT.K .AND. K.GT.0) ) THEN
+ INFO = -7
+ ELSE IF( LDV.LT.K ) THEN
+ INFO = -9
+ ELSE IF( LDT.LT.MB ) THEN
+ INFO = -11
+ ELSE IF( LDA.LT.LDAQ ) THEN
+ INFO = -13
+ ELSE IF( LDB.LT.MAX( 1, M ) ) THEN
+ INFO = -15
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'ZTPMLQT', -INFO )
+ RETURN
+ END IF
+*
+* .. Quick return if possible ..
+*
+ IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) RETURN
+*
+ IF( LEFT .AND. NOTRAN ) THEN
+*
+ DO I = 1, K, MB
+ 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
+ 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
+ IB = MIN( MB, K-I+1 )
+ NB = MIN( N-L+I+IB-1, N )
+ IF( I.GE.L ) THEN
+ LB = 0
+ 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,
+ $ A( 1, I ), LDA, B, LDB, WORK, M )
+ END DO
+*
+ ELSE IF( LEFT .AND. TRAN ) THEN
+*
+ KF = ((K-1)/MB)*MB+1
+ DO I = KF, 1, -MB
+ 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
+ CALL ZTPRFB( 'L', 'N', '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. NOTRAN ) THEN
+*
+ KF = ((K-1)/MB)*MB+1
+ DO I = KF, 1, -MB
+ IB = MIN( MB, K-I+1 )
+ NB = MIN( N-L+I+IB-1, N )
+ IF( I.GE.L ) THEN
+ LB = 0
+ ELSE
+ 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,
+ $ A( 1, I ), LDA, B, LDB, WORK, M )
+ END DO
+*
+ END IF
+*
+ RETURN
+*
+* End of ZTPMLQT
+*
+ END
SCLNTST= slaord.o
-DZLNTST= dlaord.o
+DZLNTST= dlaord.o
SLINTST = schkaa.o \
schkeq.o schkgb.o schkge.o schkgt.o \
schklq.o schkpb.o schkpo.o schkps.o schkpp.o \
schkpt.o schkq3.o schkql.o schkqr.o schkrq.o \
- schksp.o schksy.o schksy_rook.o schksy_aasen.o schktb.o schktp.o schktr.o \
+ schksp.o schksy.o schksy_rook.o schktb.o schktp.o schktr.o \
schktz.o \
sdrvgt.o sdrvls.o sdrvpb.o \
- sdrvpp.o sdrvpt.o sdrvsp.o sdrvsy_rook.o sdrvsy_aasen.o\
+ sdrvpp.o sdrvpt.o sdrvsp.o sdrvsy_rook.o\
serrgt.o serrlq.o serrls.o \
serrps.o serrql.o serrqp.o serrqr.o \
serrrq.o serrtr.o serrtz.o \
sqrt01.o sqrt01p.o sqrt02.o sqrt03.o sqrt11.o sqrt12.o \
sqrt13.o sqrt14.o sqrt15.o sqrt16.o sqrt17.o \
srqt01.o srqt02.o srqt03.o srzt01.o srzt02.o \
- sspt01.o ssyt01.o ssyt01_rook.o ssyt01_aasen.o\
+ sspt01.o ssyt01.o ssyt01_rook.o \
stbt02.o stbt03.o stbt05.o stbt06.o stpt01.o \
stpt02.o stpt03.o stpt05.o stpt06.o strt01.o \
strt02.o strt03.o strt05.o strt06.o \
- sgennd.o sqrt04.o sqrt05.o schkqrt.o serrqrt.o schkqrtp.o serrqrtp.o
+ sgennd.o sqrt04.o sqrt05.o schkqrt.o serrqrt.o schkqrtp.o serrqrtp.o \
+ schklqt.o schklqtp.o schktsqr.o \
+ serrlqt.o serrlqtp.o serrtsqr.o stsqr01.o slqt04.o slqt05.o
ifdef USEXBLAS
SLINTST += serrvxx.o sdrvgex.o sdrvsyx.o serrgex.o sdrvgbx.o sdrvpox.o \
CLINTST = cchkaa.o \
cchkeq.o cchkgb.o cchkge.o cchkgt.o \
- cchkhe.o cchkhe_rook.o cchkhe_aasen.o cchkhp.o cchklq.o cchkpb.o \
+ cchkhe.o cchkhe_rook.o cchkhp.o cchklq.o cchkpb.o \
cchkpo.o cchkps.o cchkpp.o cchkpt.o cchkq3.o cchkql.o \
cchkqr.o cchkrq.o cchksp.o cchksy.o cchksy_rook.o cchktb.o \
cchktp.o cchktr.o cchktz.o \
- cdrvgt.o cdrvhe_rook.o cdrvhe_aasen.o cdrvhp.o \
+ cdrvgt.o cdrvhe_rook.o cdrvhp.o \
cdrvls.o cdrvpb.o cdrvpp.o cdrvpt.o \
cdrvsp.o cdrvsy_rook.o \
cerrgt.o cerrlq.o \
cgbt01.o cgbt02.o cgbt05.o cgelqs.o cgeqls.o cgeqrs.o \
cgerqs.o cget01.o cget02.o \
cget03.o cget04.o cget07.o cgtt01.o cgtt02.o \
- cgtt05.o chet01.o chet01_rook.o chet01_aasen.o chpt01.o claipd.o claptm.o clarhs.o clatb4.o clatb5.o \
+ cgtt05.o chet01.o chet01_rook.o chpt01.o claipd.o claptm.o clarhs.o clatb4.o clatb5.o \
clatsp.o clatsy.o clattb.o clattp.o clattr.o \
clavhe.o clavhe_rook.o clavhp.o clavsp.o clavsy.o clavsy_rook.o clqt01.o \
clqt02.o clqt03.o cpbt01.o cpbt02.o cpbt05.o \
ctpt02.o ctpt03.o ctpt05.o ctpt06.o ctrt01.o \
ctrt02.o ctrt03.o ctrt05.o ctrt06.o \
sget06.o cgennd.o \
- cqrt04.o cqrt05.o cchkqrt.o cerrqrt.o cchkqrtp.o cerrqrtp.o
+ cqrt04.o cqrt05.o cchkqrt.o cerrqrt.o cchkqrtp.o cerrqrtp.o \
+ cchklqt.o cchklqtp.o cchktsqr.o \
+ cerrlqt.o cerrlqtp.o cerrtsqr.o ctsqr01.o clqt04.o clqt05.o
ifdef USEXBLAS
CLINTST += cerrvxx.o cdrvgex.o cdrvsyx.o cdrvgbx.o cerrgex.o cdrvpox.o \
dchkeq.o dchkgb.o dchkge.o dchkgt.o \
dchklq.o dchkpb.o dchkpo.o dchkps.o dchkpp.o \
dchkpt.o dchkq3.o dchkql.o dchkqr.o dchkrq.o \
- dchksp.o dchksy.o dchksy_rook.o dchksy_aasen.o dchktb.o dchktp.o dchktr.o \
+ dchksp.o dchksy.o dchksy_rook.o dchktb.o dchktp.o dchktr.o \
dchktz.o \
ddrvgt.o ddrvls.o ddrvpb.o \
- ddrvpp.o ddrvpt.o ddrvsp.o ddrvsy_rook.o ddrvsy_aasen.o\
+ ddrvpp.o ddrvpt.o ddrvsp.o ddrvsy_rook.o \
derrgt.o derrlq.o derrls.o \
derrps.o derrql.o derrqp.o derrqr.o \
derrrq.o derrtr.o derrtz.o \
dqrt01.o dqrt01p.o dqrt02.o dqrt03.o dqrt11.o dqrt12.o \
dqrt13.o dqrt14.o dqrt15.o dqrt16.o dqrt17.o \
drqt01.o drqt02.o drqt03.o drzt01.o drzt02.o \
- dspt01.o dsyt01.o dsyt01_rook.o dsyt01_aasen.o\
+ dspt01.o dsyt01.o dsyt01_rook.o \
dtbt02.o dtbt03.o dtbt05.o dtbt06.o dtpt01.o \
dtpt02.o dtpt03.o dtpt05.o dtpt06.o dtrt01.o \
dtrt02.o dtrt03.o dtrt05.o dtrt06.o \
dgennd.o \
- dqrt04.o dqrt05.o dchkqrt.o derrqrt.o dchkqrtp.o derrqrtp.o
+ dqrt04.o dqrt05.o dchkqrt.o derrqrt.o dchkqrtp.o derrqrtp.o \
+ dchklq.o dchklqt.o dchklqtp.o dchktsqr.o \
+ derrlqt.o derrlqtp.o derrtsqr.o dtsqr01.o dlqt04.o dlqt05.o
ifdef USEXBLAS
DLINTST += derrvxx.o ddrvgex.o ddrvsyx.o ddrvgbx.o derrgex.o ddrvpox.o derrpox.o \
ZLINTST = zchkaa.o \
zchkeq.o zchkgb.o zchkge.o zchkgt.o \
- zchkhe.o zchkhe_rook.o zchkhe_aasen.o zchkhp.o zchklq.o zchkpb.o \
+ zchkhe.o zchkhe_rook.o zchkhp.o zchklq.o zchkpb.o \
zchkpo.o zchkps.o zchkpp.o zchkpt.o zchkq3.o zchkql.o \
zchkqr.o zchkrq.o zchksp.o zchksy.o zchksy_rook.o zchktb.o \
zchktp.o zchktr.o zchktz.o \
- zdrvgt.o zdrvhe_rook.o zdrvhe_aasen.o zdrvhp.o \
+ zdrvgt.o zdrvhe_rook.o zdrvhp.o \
zdrvls.o zdrvpb.o zdrvpp.o zdrvpt.o \
zdrvsp.o zdrvsy_rook.o \
zerrgt.o zerrlq.o \
zgbt01.o zgbt02.o zgbt05.o zgelqs.o zgeqls.o zgeqrs.o \
zgerqs.o zget01.o zget02.o \
zget03.o zget04.o zget07.o zgtt01.o zgtt02.o \
- zgtt05.o zhet01.o zhet01_rook.o zhet01_aasen.o zhpt01.o zlaipd.o zlaptm.o zlarhs.o zlatb4.o zlatb5.o \
+ zgtt05.o zhet01.o zhet01_rook.o zhpt01.o zlaipd.o zlaptm.o zlarhs.o zlatb4.o zlatb5.o \
zlatsp.o zlatsy.o zlattb.o zlattp.o zlattr.o \
zlavhe.o zlavhe_rook.o zlavhp.o zlavsp.o zlavsy.o zlavsy_rook.o zlqt01.o \
zlqt02.o zlqt03.o zpbt01.o zpbt02.o zpbt05.o \
ztpt02.o ztpt03.o ztpt05.o ztpt06.o ztrt01.o \
ztrt02.o ztrt03.o ztrt05.o ztrt06.o \
dget06.o zgennd.o \
- zqrt04.o zqrt05.o zchkqrt.o zerrqrt.o zchkqrtp.o zerrqrtp.o
+ zqrt04.o zqrt05.o zchkqrt.o zerrqrt.o zchkqrtp.o zerrqrtp.o \
+ zchklqt.o zchklqtp.o zchktsqr.o \
+ zerrlqt.o zerrlqtp.o zerrtsqr.o ztsqr01.o zlqt04.o zlqt05.o
ifdef USEXBLAS
ZLINTST += zerrvxx.o zdrvgex.o zdrvsyx.o zdrvgbx.o zerrgex.o zdrvpox.o zdrvhex.o \
SLINTSTRFP = schkrfp.o sdrvrfp.o sdrvrf1.o sdrvrf2.o sdrvrf3.o sdrvrf4.o serrrfp.o \
slatb4.o slarhs.o sget04.o spot01.o spot03.o spot02.o \
- chkxer.o xerbla.o alaerh.o aladhd.o alahd.o alasvm.o
+ chkxer.o xerbla.o alaerh.o aladhd.o alahd.o alasvm.o
DLINTSTRFP = dchkrfp.o ddrvrfp.o ddrvrf1.o ddrvrf2.o ddrvrf3.o ddrvrf4.o derrrfp.o \
dlatb4.o dlarhs.o dget04.o dpot01.o dpot03.o dpot02.o \
- chkxer.o xerbla.o alaerh.o aladhd.o alahd.o alasvm.o
+ chkxer.o xerbla.o alaerh.o aladhd.o alahd.o alasvm.o
CLINTSTRFP = cchkrfp.o cdrvrfp.o cdrvrf1.o cdrvrf2.o cdrvrf3.o cdrvrf4.o cerrrfp.o \
claipd.o clatb4.o clarhs.o csbmv.o cget04.o cpot01.o cpot03.o cpot02.o \
- chkxer.o xerbla.o alaerh.o aladhd.o alahd.o alasvm.o
+ chkxer.o xerbla.o alaerh.o aladhd.o alahd.o alasvm.o
ZLINTSTRFP = zchkrfp.o zdrvrfp.o zdrvrf1.o zdrvrf2.o zdrvrf3.o zdrvrf4.o zerrrfp.o \
zlatb4.o zlaipd.o zlarhs.o zsbmv.o zget04.o zpot01.o zpot03.o zpot02.o \
- chkxer.o xerbla.o alaerh.o aladhd.o alahd.o alasvm.o
+ chkxer.o xerbla.o alaerh.o aladhd.o alahd.o alasvm.o
all: single double complex complex16 proto-single proto-double proto-complex proto-complex16
single: ../xlintsts
-double: ../xlintstd
+double: ../xlintstd
complex: ../xlintstc
-complex16: ../xlintstz
+complex16: ../xlintstz
proto-single: ../xlintstrfs
proto-double: ../xlintstds ../xlintstrfd
xlintstc : $(ALINTST) $(CLINTST) $(SCLNTST) ../../$(LAPACKLIB)
$(LOADER) $(LOADOPTS) $(ALINTST) $(SCLNTST) $(CLINTST) \
../../$(TMGLIB) ../../$(LAPACKLIB) $(XBLASLIB) $(BLASLIB) -o $@
-
+
xlintstd : $(ALINTST) $(DLINTST) $(DZLNTST) ../../$(LAPACKLIB)
$(LOADER) $(LOADOPTS) $^ \
../../$(TMGLIB) ../../$(LAPACKLIB) $(XBLASLIB) $(BLASLIB) -o $@
-
+
xlintstz : $(ALINTST) $(ZLINTST) $(DZLNTST) ../../$(LAPACKLIB)
$(LOADER) $(LOADOPTS) $(ALINTST) $(DZLNTST) $(ZLINTST) \
../../$(TMGLIB) ../../$(LAPACKLIB) $(XBLASLIB) $(BLASLIB) -o $@
-
+
xlintstds : $(DSLINTST) ../../$(LAPACKLIB)
$(LOADER) $(LOADOPTS) $(DSLINTST) \
../../$(TMGLIB) ../../$(LAPACKLIB) $(BLASLIB) -o $@
-
+
xlintstzc : $(ZCLINTST) ../../$(LAPACKLIB)
$(LOADER) $(LOADOPTS) $(ZCLINTST) \
../../$(TMGLIB) ../../$(LAPACKLIB) $(BLASLIB) -o $@
-
+
xlintstrfs : $(SLINTSTRFP) ../../$(LAPACKLIB)
$(LOADER) $(LOADOPTS) $(SLINTSTRFP) \
../../$(TMGLIB) ../../$(LAPACKLIB) $(BLASLIB) -o $@
-
+
xlintstrfd : $(DLINTSTRFP) ../../$(LAPACKLIB)
$(LOADER) $(LOADOPTS) $(DLINTSTRFP) \
../../$(TMGLIB) ../../$(LAPACKLIB) $(BLASLIB) -o $@
-
+
xlintstrfc : $(CLINTSTRFP) ../../$(LAPACKLIB)
$(LOADER) $(LOADOPTS) $(CLINTSTRFP) \
../../$(TMGLIB) ../../$(LAPACKLIB) $(BLASLIB) -o $@
-
+
xlintstrfz : $(ZLINTSTRFP) ../../$(LAPACKLIB)
$(LOADER) $(LOADOPTS) $(ZLINTSTRFP) \
../../$(TMGLIB) ../../$(LAPACKLIB) $(BLASLIB) -o $@
-
+
../xlintsts: xlintsts
mv xlintsts $@
FRC:
@FRC=$(FRC)
-
+
clean:
rm -f *.o
$(FORTRAN) $(DRVOPTS) -c $< -o $@
zchkaa.o: zchkaa.f
$(FORTRAN) $(DRVOPTS) -c $< -o $@
-
-.f.o:
+
+.f.o:
$(FORTRAN) $(OPTS) -c $< -o $@
.NOTPARALLEL:
*
* =========== 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 ALAERH( PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU,
* N5, IMAT, NFAIL, NERRS, NOUT )
-*
+*
* .. Scalar Arguments ..
* CHARACTER*3 PATH
* CHARACTER*( * ) SUBNAM
* INTEGER IMAT, INFO, INFOE, KL, KU, M, N, N5, NERRS,
* $ NFAIL, NOUT
* ..
-*
+*
*
*> \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 2013
*
ELSE IF( LSAMEN( 2, P2, 'SY' )
$ .OR. LSAMEN( 2, P2, 'SR' )
$ .OR. LSAMEN( 2, P2, 'HE' )
- $ .OR. LSAMEN( 2, P2, 'HA' )
$ .OR. LSAMEN( 2, P2, 'HR' ) ) THEN
*
* xSY: symmetric indefinite matrices
* with rook (bounded Bunch-Kaufman) pivoting;
* xHE: Hermitian indefinite matrices
* with partial (Bunch-Kaufman) pivoting.
-* xHA: Hermitian matrices
-* Aasen Algorithm
* xHR: Hermitian indefinite matrices
* with rook (bounded Bunch-Kaufman) pivoting;
*
*> with "rook" (bounded Bunch-Kaufman) pivoting
*> _SP: Symmetric indefinite packed,
*> with partial (Bunch-Kaufman) pivoting
-*> _HA: (complex) Hermitian ,
-*> with Aasen Algorithm
*> _HE: (complex) Hermitian indefinite,
*> with partial (Bunch-Kaufman) pivoting
*> _HR: Symmetric indefinite,
WRITE( IOUNIT, FMT = 9955 )8
WRITE( IOUNIT, FMT = '( '' Messages:'' )' )
*
- ELSE IF( LSAMEN( 2, P2, 'HA' ) ) THEN
-*
-* HA: Hermitian,
-* with Assen Algorithm
-*
- WRITE( IOUNIT, FMT = 9992 )PATH, 'Hermitian'
-*
- WRITE( IOUNIT, FMT = '( '' Matrix types:'' )' )
- WRITE( IOUNIT, FMT = 9972 )
-*
- WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' )
- WRITE( IOUNIT, FMT = 9953 )1
- WRITE( IOUNIT, FMT = 9961 )2
- WRITE( IOUNIT, FMT = 9960 )3
- WRITE( IOUNIT, FMT = 9960 )4
- WRITE( IOUNIT, FMT = 9959 )5
- WRITE( IOUNIT, FMT = 9958 )6
- WRITE( IOUNIT, FMT = 9956 )7
- WRITE( IOUNIT, FMT = 9957 )8
- WRITE( IOUNIT, FMT = 9955 )9
- WRITE( IOUNIT, FMT = '( '' Messages:'' )' )
-*
ELSE IF( LSAMEN( 2, P2, 'HE' ) ) THEN
*
* HE: Hermitian indefinite full,
*
WRITE( IOUNIT, FMT = 9984 )PATH
WRITE( IOUNIT, FMT = 9967 )
- WRITE( IOUNIT, FMT = 9921 )C1, C1, C1, C1
+ WRITE( IOUNIT, FMT = 9921 )C1, C1, C1, C1, C1
WRITE( IOUNIT, FMT = 9935 )1
WRITE( IOUNIT, FMT = 9931 )2
WRITE( IOUNIT, FMT = 9933 )3
WRITE( IOUNIT, FMT = 8021 ) 5
WRITE( IOUNIT, FMT = 8022 ) 6
*
+ ELSE IF( LSAMEN( 2, P2, 'TQ' ) ) THEN
+*
+* QRT (triangular-pentagonal)
+*
+ WRITE( IOUNIT, FMT = 8002 ) PATH
+ WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' )
+ WRITE( IOUNIT, FMT = 8023 ) 1
+ WRITE( IOUNIT, FMT = 8024 ) 2
+ WRITE( IOUNIT, FMT = 8025 ) 3
+ WRITE( IOUNIT, FMT = 8026 ) 4
+ WRITE( IOUNIT, FMT = 8027 ) 5
+ WRITE( IOUNIT, FMT = 8028 ) 6
+*
+ ELSE IF( LSAMEN( 2, P2, 'XQ' ) ) THEN
+*
+* QRT (triangular-pentagonal)
+*
+ WRITE( IOUNIT, FMT = 8003 ) PATH
+ WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' )
+ WRITE( IOUNIT, FMT = 8029 ) 1
+ WRITE( IOUNIT, FMT = 8030 ) 2
+ WRITE( IOUNIT, FMT = 8031 ) 3
+ WRITE( IOUNIT, FMT = 8032 ) 4
+ WRITE( IOUNIT, FMT = 8033 ) 5
+ WRITE( IOUNIT, FMT = 8034 ) 6
+*
+ ELSE IF( LSAMEN( 2, P2, 'TS' ) ) THEN
+*
+* QRT (triangular-pentagonal)
+*
+ WRITE( IOUNIT, FMT = 8004 ) PATH
+ WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' )
+ WRITE( IOUNIT, FMT = 8035 ) 1
+ WRITE( IOUNIT, FMT = 8036 ) 2
+ WRITE( IOUNIT, FMT = 8037 ) 3
+ WRITE( IOUNIT, FMT = 8038 ) 4
+ WRITE( IOUNIT, FMT = 8039 ) 5
+ WRITE( IOUNIT, FMT = 8040 ) 6
+*
ELSE
*
* Print error message if no header is available.
8000 FORMAT( / 1X, A3, ': QRT factorization for general matrices' )
8001 FORMAT( / 1X, A3, ': QRT factorization for ',
$ 'triangular-pentagonal matrices' )
+ 8002 FORMAT( / 1X, A3, ': LQT factorization for general matrices' )
+ 8003 FORMAT( / 1X, A3, ': LQT factorization for ',
+ $ 'triangular-pentagonal matrices' )
+ 8004 FORMAT( / 1X, A3, ': TS factorization for ',
+ $ 'tall-skiny or short-wide matrices' )
*
* GE matrix types
*
9929 FORMAT( ' Test ratios (1-3: ', A1, 'TZRZF):' )
9920 FORMAT( 3X, ' 7-10: same as 3-6', 3X, ' 11-14: same as 3-6' )
9921 FORMAT( ' Test ratios:', / ' (1-2: ', A1, 'GELS, 3-6: ', A1,
- $ 'GELSY, 7-10: ', A1, 'GELSS, 11-14: ', A1, 'GELSD)' )
+ $ 'GELSY, 7-10: ', A1, 'GELSS, 11-14: ', A1, 'GELSD, 15-16: '
+ $ A1, 'GETSLS)')
9928 FORMAT( 7X, 'where ALPHA = ( 1 + SQRT( 17 ) ) / 8' )
9927 FORMAT( 3X, I2, ': ABS( Largest element in L )', / 12X,
$ ' - ( 1 / ( 1 - ALPHA ) ) + THRESH' )
8021 FORMAT(3X,I2,': norm( C*Q - C*Q ) / ( (M+N) * norm(C) * EPS )' )
8022 FORMAT(3X,I2,
$ ': norm( C*Q'' - C*Q'' ) / ( (M+N) * norm(C) * EPS )')
+ 8023 FORMAT(3X,I2,': norm( L - A*Q'' ) / ( (M+N) * norm(A) * EPS )' )
+ 8024 FORMAT(3X,I2,': norm( I - Q*Q'' ) / ( (M+N) * EPS )' )
+ 8025 FORMAT(3X,I2,': norm( Q*C - Q*C ) / ( (M+N) * norm(C) * EPS )' )
+ 8026 FORMAT(3X,I2,
+ $ ': norm( Q''*C - Q''*C ) / ( (M+N) * norm(C) * EPS )')
+ 8027 FORMAT(3X,I2,': norm( C*Q - C*Q ) / ( (M+N) * norm(C) * EPS )' )
+ 8028 FORMAT(3X,I2,
+ $ ': norm( C*Q'' - C*Q'' ) / ( (M+N) * norm(C) * EPS )')
+ 8029 FORMAT(3X,I2,': norm( L - A*Q'' ) / ( (M+N) * norm(A) * EPS )' )
+ 8030 FORMAT(3X,I2,': norm( I - Q*Q'' ) / ( (M+N) * EPS )' )
+ 8031 FORMAT(3X,I2,': norm( Q*C - Q*C ) / ( (M+N) * norm(C) * EPS )' )
+ 8032 FORMAT(3X,I2,
+ $ ': norm( Q''*C - Q''*C ) / ( (M+N) * norm(C) * EPS )')
+ 8033 FORMAT(3X,I2,': norm( C*Q - C*Q ) / ( (M+N) * norm(C) * EPS )' )
+ 8034 FORMAT(3X,I2,
+ $ ': norm( C*Q'' - C*Q'' ) / ( (M+N) * norm(C) * EPS )')
+ 8035 FORMAT(3X,I2,': norm( R - Q''*A ) / ( (M+N) * norm(A) * EPS )' )
+ 8036 FORMAT(3X,I2,': norm( I - Q''*Q ) / ( (M+N) * EPS )' )
+ 8037 FORMAT(3X,I2,': norm( Q*C - Q*C ) / ( (M+N) * norm(C) * EPS )' )
+ 8038 FORMAT(3X,I2,
+ $ ': norm( Q''*C - Q''*C ) / ( (M+N) * norm(C) * EPS )')
+ 8039 FORMAT(3X,I2,': norm( C*Q - C*Q ) / ( (M+N) * norm(C) * EPS )' )
+ 8040 FORMAT(3X,I2,
+ $ ': norm( C*Q'' - C*Q'' ) / ( (M+N) * norm(C) * EPS )')
*
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:
* ===========
*
* PROGRAM CCHKAA
-*
+*
*
*> \par Purpose:
* =============
*> CPT 12 List types on next line if 0 < NTYPES < 12
*> CHE 10 List types on next line if 0 < NTYPES < 10
*> CHR 10 List types on next line if 0 < NTYPES < 10
-*> CHA 10 List types on next line if 0 < NTYPES < 10
*> CHP 10 List types on next line if 0 < NTYPES < 10
*> CSY 11 List types on next line if 0 < NTYPES < 11
*> CSR 11 List types on next line if 0 < NTYPES < 11
* 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
+*> \date November 2015
*
*> \ingroup complex_lin
*
* =====================================================================
PROGRAM CCHKAA
*
-* -- LAPACK test routine (version 3.7.0) --
+* -- LAPACK test routine (version 3.6.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* November 2016
+* November 2015
*
* =====================================================================
*
WRITE( NOUT, FMT = 9988 )PATH
END IF
*
- ELSE IF( LSAMEN( 2, C2, 'HA' ) ) THEN
-*
-* HA: Hermitian matrices,
-* Aasen Algorithm
-*
- NTYPES = 10
- CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
-*
- IF( TSTCHK ) THEN
- CALL CCHKHE_AASEN( DOTYPE, NN, NVAL, NNB2, NBVAL2, NNS,
- $ 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 )
- ELSE
- WRITE( NOUT, FMT = 9989 )PATH
- 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 ),
- $ WORK, RWORK, IWORK, NOUT )
- ELSE
- WRITE( NOUT, FMT = 9988 )PATH
- END IF
-*
ELSE IF( LSAMEN( 2, C2, 'HR' ) ) THEN
*
* HR: Hermitian indefinite matrices,
ELSE
WRITE( NOUT, FMT = 9989 )PATH
END IF
+
*
ELSE IF( LSAMEN( 2, C2, 'RQ' ) ) THEN
*
ELSE
WRITE( NOUT, FMT = 9989 )PATH
END IF
+
*
ELSE IF( LSAMEN( 2, C2, 'LS' ) ) THEN
*
* QT: QRT routines for general matrices
*
IF( TSTCHK ) THEN
- CALL CCHKQRT( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
+ CALL CCHKQRT( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
$ NBVAL, NOUT )
ELSE
WRITE( NOUT, FMT = 9989 )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
+ END IF
+*
+ ELSE IF( LSAMEN( 2, C2, 'TQ' ) ) THEN
+*
+* TQ: LQT routines for general matrices
+*
+ IF( TSTCHK ) THEN
+ CALL CCHKLQT( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
+ $ NBVAL, NOUT )
+ ELSE
+ WRITE( NOUT, FMT = 9989 )PATH
+ END IF
+*
+ ELSE IF( LSAMEN( 2, C2, 'XQ' ) ) THEN
+*
+* XQ: LQT routines for triangular-pentagonal matrices
+*
+ IF( TSTCHK ) THEN
+ CALL CCHKLQTP( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
+ $ NBVAL, NOUT )
+ ELSE
+ WRITE( NOUT, FMT = 9989 )PATH
+ END IF
+*
+ ELSE IF( LSAMEN( 2, C2, 'TS' ) ) THEN
+*
+* TS: QR routines for tall-skinny matrices
+*
+ IF( TSTCHK ) THEN
+ CALL CCHKTSQR( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
$ NBVAL, NOUT )
ELSE
WRITE( NOUT, FMT = 9989 )PATH
--- /dev/null
+*> \brief \b CCHKLQT
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE CCHKLQT( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
+* NBVAL, NOUT )
+*
+* .. Scalar Arguments ..
+* LOGICAL TSTERR
+* INTEGER NM, NN, NNB, NOUT
+* REAL THRESH
+* ..
+* .. Array Arguments ..
+* INTEGER MVAL( * ), NBVAL( * ), NVAL( * )
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> CCHKLQT tests CGELQT and CUNMLQT.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] THRESH
+*> \verbatim
+*> THRESH is REAL
+*> The threshold value for the test ratios. A result is
+*> included in the output file if RESULT >= THRESH. To have
+*> every test ratio printed, use THRESH = 0.
+*> \endverbatim
+*>
+*> \param[in] TSTERR
+*> \verbatim
+*> TSTERR is LOGICAL
+*> Flag that indicates whether error exits are to be tested.
+*> \endverbatim
+*>
+*> \param[in] NM
+*> \verbatim
+*> NM is INTEGER
+*> The number of values of M contained in the vector MVAL.
+*> \endverbatim
+*>
+*> \param[in] MVAL
+*> \verbatim
+*> MVAL is INTEGER array, dimension (NM)
+*> The values of the matrix row dimension M.
+*> \endverbatim
+*>
+*> \param[in] NN
+*> \verbatim
+*> NN is INTEGER
+*> The number of values of N contained in the vector NVAL.
+*> \endverbatim
+*>
+*> \param[in] NVAL
+*> \verbatim
+*> NVAL is INTEGER array, dimension (NN)
+*> The values of the matrix column dimension N.
+*> \endverbatim
+*>
+*> \param[in] NNB
+*> \verbatim
+*> NNB is INTEGER
+*> The number of values of NB contained in the vector NBVAL.
+*> \endverbatim
+*>
+*> \param[in] NBVAL
+*> \verbatim
+*> NBVAL is INTEGER array, dimension (NBVAL)
+*> The values of the blocksize NB.
+*> \endverbatim
+*>
+*> \param[in] NOUT
+*> \verbatim
+*> NOUT is INTEGER
+*> The unit number for output.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \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,
+ $ NBVAL, NOUT )
+ IMPLICIT NONE
+*
+* -- LAPACK test routine (version 3.4.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2011
+*
+* .. Scalar Arguments ..
+ LOGICAL TSTERR
+ INTEGER NM, NN, NNB, NOUT
+ REAL THRESH
+* ..
+* .. Array Arguments ..
+ INTEGER MVAL( * ), NBVAL( * ), NVAL( * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER NTESTS
+ PARAMETER ( NTESTS = 6 )
+* ..
+* .. Local Scalars ..
+ CHARACTER*3 PATH
+ INTEGER I, J, K, T, M, N, NB, NFAIL, NERRS, NRUN,
+ $ MINMN
+*
+* .. Local Arrays ..
+ REAL RESULT( NTESTS )
+* ..
+* .. External Subroutines ..
+ EXTERNAL ALAERH, ALAHD, ALASUM, CERRLQT, CLQT04
+* ..
+* .. Scalars in Common ..
+ LOGICAL LERR, OK
+ CHARACTER*32 SRNAMT
+ INTEGER INFOT, NUNIT
+* ..
+* .. Common blocks ..
+ COMMON / INFOC / INFOT, NUNIT, OK, LERR
+ COMMON / SRNAMC / SRNAMT
+* ..
+* .. Executable Statements ..
+*
+* Initialize constants
+*
+ PATH( 1: 1 ) = 'C'
+ PATH( 2: 3 ) = 'TQ'
+ NRUN = 0
+ NFAIL = 0
+ NERRS = 0
+*
+* Test the error exits
+*
+ IF( TSTERR ) CALL CERRLQT( PATH, NOUT )
+ INFOT = 0
+*
+* Do for each value of M in MVAL.
+*
+ DO I = 1, NM
+ M = MVAL( I )
+*
+* Do for each value of N in NVAL.
+*
+ DO J = 1, NN
+ N = NVAL( J )
+*
+* Do for each possible value of NB
+*
+ MINMN = MIN( M, N )
+ DO K = 1, NNB
+ NB = NBVAL( K )
+*
+* Test CGELQT and CUNMLQT
+*
+ IF( (NB.LE.MINMN).AND.(NB.GT.0) ) THEN
+ CALL CLQT04( M, N, NB, RESULT )
+*
+* Print information about the tests that did not
+* pass the threshold.
+*
+ DO T = 1, NTESTS
+ IF( RESULT( T ).GE.THRESH ) THEN
+ IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
+ $ CALL ALAHD( NOUT, PATH )
+ WRITE( NOUT, FMT = 9999 )M, N, NB,
+ $ T, RESULT( T )
+ NFAIL = NFAIL + 1
+ END IF
+ END DO
+ NRUN = NRUN + NTESTS
+ END IF
+ END DO
+ END DO
+ END DO
+*
+* Print a summary of the results.
+*
+ CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
+*
+ 9999 FORMAT( ' M=', I5, ', N=', I5, ', NB=', I4,
+ $ ' test(', I2, ')=', G12.5 )
+ RETURN
+*
+* End of CCHKLQT
+*
+ END
--- /dev/null
+*> \brief \b CCHKLQTP
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE CCHKLQTP( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
+* NBVAL, NOUT )
+*
+* .. Scalar Arguments ..
+* LOGICAL TSTERR
+* INTEGER NM, NN, NNB, NOUT
+* REAL THRESH
+* ..
+* .. Array Arguments ..
+* INTEGER MVAL( * ), NBVAL( * ), NVAL( * )
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> CCHKLQTP tests CTPLQT and CTPMLQT.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] THRESH
+*> \verbatim
+*> THRESH is REAL
+*> The threshold value for the test ratios. A result is
+*> included in the output file if RESULT >= THRESH. To have
+*> every test ratio printed, use THRESH = 0.
+*> \endverbatim
+*>
+*> \param[in] TSTERR
+*> \verbatim
+*> TSTERR is LOGICAL
+*> Flag that indicates whether error exits are to be tested.
+*> \endverbatim
+*>
+*> \param[in] NM
+*> \verbatim
+*> NM is INTEGER
+*> The number of values of M contained in the vector MVAL.
+*> \endverbatim
+*>
+*> \param[in] MVAL
+*> \verbatim
+*> MVAL is INTEGER array, dimension (NM)
+*> The values of the matrix row dimension M.
+*> \endverbatim
+*>
+*> \param[in] NN
+*> \verbatim
+*> NN is INTEGER
+*> The number of values of N contained in the vector NVAL.
+*> \endverbatim
+*>
+*> \param[in] NVAL
+*> \verbatim
+*> NVAL is INTEGER array, dimension (NN)
+*> The values of the matrix column dimension N.
+*> \endverbatim
+*>
+*> \param[in] NNB
+*> \verbatim
+*> NNB is INTEGER
+*> The number of values of NB contained in the vector NBVAL.
+*> \endverbatim
+*>
+*> \param[in] NBVAL
+*> \verbatim
+*> NBVAL is INTEGER array, dimension (NBVAL)
+*> The values of the blocksize NB.
+*> \endverbatim
+*>
+*> \param[in] NOUT
+*> \verbatim
+*> NOUT is INTEGER
+*> The unit number for output.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \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,
+ $ NBVAL, NOUT )
+ IMPLICIT NONE
+*
+* -- LAPACK test routine (version 3.4.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2011
+*
+* .. Scalar Arguments ..
+ LOGICAL TSTERR
+ INTEGER NM, NN, NNB, NOUT
+ REAL THRESH
+* ..
+* .. Array Arguments ..
+ INTEGER MVAL( * ), NBVAL( * ), NVAL( * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER NTESTS
+ PARAMETER ( NTESTS = 6 )
+* ..
+* .. Local Scalars ..
+ CHARACTER*3 PATH
+ INTEGER I, J, K, L, T, M, N, NB, NFAIL, NERRS, NRUN,
+ $ MINMN
+* ..
+* .. Local Arrays ..
+ REAL RESULT( NTESTS )
+* ..
+* .. External Subroutines ..
+ EXTERNAL ALAERH, ALAHD, ALASUM, CERRLQTP, CLQT04
+* ..
+* .. Scalars in Common ..
+ LOGICAL LERR, OK
+ CHARACTER*32 SRNAMT
+ INTEGER INFOT, NUNIT
+* ..
+* .. Common blocks ..
+ COMMON / INFOC / INFOT, NUNIT, OK, LERR
+ COMMON / SRNAMC / SRNAMT
+* ..
+* .. Executable Statements ..
+*
+* Initialize constants
+*
+ PATH( 1: 1 ) = 'C'
+ PATH( 2: 3 ) = 'XQ'
+ NRUN = 0
+ NFAIL = 0
+ NERRS = 0
+*
+* Test the error exits
+*
+ IF( TSTERR ) CALL CERRLQTP( PATH, NOUT )
+ INFOT = 0
+*
+* Do for each value of M
+*
+ DO I = 1, NM
+ M = MVAL( I )
+*
+* Do for each value of N
+*
+ DO J = 1, NN
+ N = NVAL( J )
+*
+* Do for each value of L
+*
+ 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 )
+*
+* Print information about the tests that did not
+* pass the threshold.
+*
+ DO T = 1, NTESTS
+ IF( RESULT( T ).GE.THRESH ) THEN
+ IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
+ $ CALL ALAHD( NOUT, PATH )
+ WRITE( NOUT, FMT = 9999 )M, N, NB, L,
+ $ T, RESULT( T )
+ NFAIL = NFAIL + 1
+ END IF
+ END DO
+ NRUN = NRUN + NTESTS
+ END IF
+ END DO
+ END DO
+ END DO
+ END DO
+*
+* Print a summary of the results.
+*
+ CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
+*
+ 9999 FORMAT( ' M=', I5, ', N=', I5, ', NB=', I4,' L=', I4,
+ $ ' test(', I2, ')=', G12.5 )
+ RETURN
+*
+* End of CCHKLQTP
+*
+ END
\ No newline at end of file
--- /dev/null
+*> \brief \b CCHKQRT
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE CCHKTSQR( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
+* NBVAL, NOUT )
+*
+* .. Scalar Arguments ..
+* LOGICAL TSTERR
+* INTEGER NM, NN, NNB, NOUT
+* REAL THRESH
+* ..
+* .. Array Arguments ..
+* INTEGER MVAL( * ), NBVAL( * ), NVAL( * )
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> CCHKTSQR tests CGEQR and CGEMQR.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] THRESH
+*> \verbatim
+*> THRESH is REAL
+*> The threshold value for the test ratios. A result is
+*> included in the output file if RESULT >= THRESH. To have
+*> every test ratio printed, use THRESH = 0.
+*> \endverbatim
+*>
+*> \param[in] TSTERR
+*> \verbatim
+*> TSTERR is LOGICAL
+*> Flag that indicates whether error exits are to be tested.
+*> \endverbatim
+*>
+*> \param[in] NM
+*> \verbatim
+*> NM is INTEGER
+*> The number of values of M contained in the vector MVAL.
+*> \endverbatim
+*>
+*> \param[in] MVAL
+*> \verbatim
+*> MVAL is INTEGER array, dimension (NM)
+*> The values of the matrix row dimension M.
+*> \endverbatim
+*>
+*> \param[in] NN
+*> \verbatim
+*> NN is INTEGER
+*> The number of values of N contained in the vector NVAL.
+*> \endverbatim
+*>
+*> \param[in] NVAL
+*> \verbatim
+*> NVAL is INTEGER array, dimension (NN)
+*> The values of the matrix column dimension N.
+*> \endverbatim
+*>
+*> \param[in] NNB
+*> \verbatim
+*> NNB is INTEGER
+*> The number of values of NB contained in the vector NBVAL.
+*> \endverbatim
+*>
+*> \param[in] NBVAL
+*> \verbatim
+*> NBVAL is INTEGER array, dimension (NBVAL)
+*> The values of the blocksize NB.
+*> \endverbatim
+*>
+*> \param[in] NOUT
+*> \verbatim
+*> NOUT is INTEGER
+*> The unit number for output.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \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,
+ $ NBVAL, NOUT )
+ IMPLICIT NONE
+*
+* -- LAPACK test routine (version 3.4.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2011
+*
+* .. Scalar Arguments ..
+ LOGICAL TSTERR
+ INTEGER NM, NN, NNB, NOUT
+ REAL THRESH
+* ..
+* .. Array Arguments ..
+ INTEGER MVAL( * ), NBVAL( * ), NVAL( * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER NTESTS
+ PARAMETER ( NTESTS = 6 )
+* ..
+* .. Local Scalars ..
+ CHARACTER*3 PATH
+ INTEGER I, J, K, T, M, N, NB, NFAIL, NERRS, NRUN, INB,
+ $ MINMN, MB, IMB
+*
+* .. Local Arrays ..
+ REAL RESULT( NTESTS )
+* ..
+* .. External Subroutines ..
+ EXTERNAL ALAERH, ALAHD, ALASUM, CERRTSQR,
+ $ CTSQR01, XLAENV
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Scalars in Common ..
+ LOGICAL LERR, OK
+ CHARACTER*32 SRNAMT
+ INTEGER INFOT, NUNIT
+* ..
+* .. Common blocks ..
+ COMMON / INFOC / INFOT, NUNIT, OK, LERR
+ COMMON / SRNAMC / SRNAMT
+* ..
+* .. Executable Statements ..
+*
+* Initialize constants
+*
+ PATH( 1: 1 ) = 'C'
+ PATH( 2: 3 ) = 'TS'
+ NRUN = 0
+ NFAIL = 0
+ NERRS = 0
+*
+* Test the error exits
+*
+ IF( TSTERR ) CALL CERRTSQR( PATH, NOUT )
+ INFOT = 0
+*
+* Do for each value of M in MVAL.
+*
+ DO I = 1, NM
+ M = MVAL( I )
+*
+* Do for each value of N in NVAL.
+*
+ DO J = 1, NN
+ N = NVAL( J )
+ IF (MIN(M,N).NE.0) THEN
+ DO INB = 1, NNB
+ MB = NBVAL( INB )
+ CALL XLAENV( 1, MB )
+ DO IMB = 1, NNB
+ NB = NBVAL( IMB )
+ CALL XLAENV( 2, NB )
+*
+* Test DGEQR and DGEMQR
+*
+ CALL CTSQR01( 'TS', M, N, MB, NB, RESULT )
+*
+* Print information about the tests that did not
+* pass the threshold.
+*
+ DO T = 1, NTESTS
+ IF( RESULT( T ).GE.THRESH ) THEN
+ IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
+ $ CALL ALAHD( NOUT, PATH )
+ WRITE( NOUT, FMT = 9999 )M, N, MB, NB,
+ $ T, RESULT( T )
+ NFAIL = NFAIL + 1
+ END IF
+ END DO
+ NRUN = NRUN + NTESTS
+ END DO
+ END DO
+ END IF
+ END DO
+ END DO
+*
+* Do for each value of M in MVAL.
+*
+ DO I = 1, NM
+ M = MVAL( I )
+*
+* Do for each value of N in NVAL.
+*
+ DO J = 1, NN
+ N = NVAL( J )
+ IF (MIN(M,N).NE.0) THEN
+ DO INB = 1, NNB
+ MB = NBVAL( INB )
+ CALL XLAENV( 1, MB )
+ DO IMB = 1, NNB
+ NB = NBVAL( IMB )
+ CALL XLAENV( 2, NB )
+*
+* Test DGEQR and DGEMQR
+*
+ CALL CTSQR01( 'SW', M, N, MB, NB, RESULT )
+*
+* Print information about the tests that did not
+* pass the threshold.
+*
+ DO T = 1, NTESTS
+ IF( RESULT( T ).GE.THRESH ) THEN
+ IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
+ $ CALL ALAHD( NOUT, PATH )
+ WRITE( NOUT, FMT = 9998 )M, N, MB, NB,
+ $ T, RESULT( T )
+ NFAIL = NFAIL + 1
+ END IF
+ END DO
+ NRUN = NRUN + NTESTS
+ END DO
+ END DO
+ END IF
+ END DO
+ END DO
+*
+* Print a summary of the results.
+*
+ CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
+*
+ 9999 FORMAT( 'TS: M=', I5, ', N=', I5, ', MB=', I5,
+ $ ', NB=', I5,' test(', I2, ')=', G12.5 )
+ 9998 FORMAT( 'SW: M=', I5, ', N=', I5, ', MB=', I5,
+ $ ', NB=', I5,' test(', I2, ')=', G12.5 )
+ RETURN
+*
+* End of CCHKQRT
+*
+ 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 CDRVLS( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, NNB,
* NBVAL, NXVAL, THRESH, TSTERR, A, COPYA, B,
-* COPYB, C, S, COPYS, WORK, RWORK, IWORK,
-* NOUT )
-*
+* COPYB, C, S, COPYS, WORK, RWORK, IWORK, NOUT )
+*
* .. Scalar Arguments ..
* LOGICAL TSTERR
* INTEGER NM, NN, NNB, NNS, NOUT
-* REAL THRESH
+* REAL THRESH
* ..
* .. Array Arguments ..
* LOGICAL DOTYPE( * )
* INTEGER IWORK( * ), MVAL( * ), NBVAL( * ), NSVAL( * ),
* $ NVAL( * ), NXVAL( * )
-* REAL COPYS( * ), RWORK( * ), S( * )
-* COMPLEX A( * ), B( * ), C( * ), COPYA( * ), COPYB( * ),
+* REAL COPYS( * ), RWORK( * ), S( * )
+* COMPLEX A( * ), B( * ), C( * ), COPYA( * ), COPYB( * ),
* $ 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 2015
*
-*> \ingroup complex_lin
+*> \ingroup complex16_lin
*
* =====================================================================
SUBROUTINE CDRVLS( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, NNB,
$ NBVAL, NXVAL, THRESH, TSTERR, A, COPYA, B,
- $ COPYB, C, S, COPYS, WORK, RWORK, IWORK,
- $ NOUT )
+ $ COPYB, C, S, COPYS, WORK, RWORK, IWORK, NOUT )
*
* -- LAPACK test routine (version 3.6.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
*
* .. Parameters ..
INTEGER NTESTS
- PARAMETER ( NTESTS = 14 )
+ PARAMETER ( NTESTS = 16 )
INTEGER SMLSIZ
PARAMETER ( SMLSIZ = 25 )
REAL ONE, ZERO
INTEGER CRANK, I, IM, IN, INB, INFO, INS, IRANK,
$ ISCALE, ITRAN, ITYPE, J, K, LDA, LDB, LDWORK,
$ LWLSY, LWORK, M, MNMIN, N, NB, NCOLS, NERRS,
- $ NFAIL, NRHS, NROWS, NRUN, RANK
+ $ NFAIL, NRHS, NROWS, NRUN, RANK, MB, LWTS
REAL EPS, NORMA, NORMB, RCOND
* ..
* .. Local Arrays ..
REAL RESULT( NTESTS )
* ..
* .. External Functions ..
- REAL CQRT12, CQRT14, CQRT17, SASUM, SLAMCH
- EXTERNAL CQRT12, CQRT14, CQRT17, SASUM, SLAMCH
+ REAL SASUM, SLAMCH, CQRT12, CQRT14, CQRT17
+ EXTERNAL SASUM, SLAMCH, CQRT12, CQRT14, CQRT17
* ..
* .. External Subroutines ..
- EXTERNAL ALAERH, ALAHD, ALASVM, CERRLS, CGELS, CGELSD,
- $ CGELSS, CGELSY, CGEMM, CLACPY, CLARNV,
- $ CQRT13, CQRT15, CQRT16, CSSCAL, SAXPY,
- $ XLAENV
+ EXTERNAL ALAERH, ALAHD, ALASVM, SAXPY, SLASRT, XLAENV,
+ $ CSSCAL, CERRLS, CGELS, CGELSD, CGELSS,
+ $ CGELSY, CGEMM, CLACPY, CLARNV, CQRT13, CQRT15,
+ $ CQRT16, CGETSLS
* ..
* .. Intrinsic Functions ..
- INTRINSIC MAX, MIN, REAL, SQRT
+ INTRINSIC REAL, MAX, MIN, SQRT
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
*
DO 130 IN = 1, NN
N = NVAL( IN )
- MNMIN = MIN( M, N )
+ MNMIN = MAX(MIN( M, N ),1)
LDB = MAX( 1, M, N )
+ MB = (MNMIN+1)
+ IF(MINMN.NE.MB) THEN
+ LWTS = (((LDB-MB)/(MB-MNMIN))*MNMIN+MNMIN*2)*MB+5
+ ELSE
+ LWTS = 2*MINMN+5
+ END IF
*
DO 120 INS = 1, NNS
NRHS = NSVAL( INS )
LWORK = MAX( 1, ( M+NRHS )*( N+2 ), ( N+NRHS )*( M+2 ),
- $ M*N+4*MNMIN+MAX( M, N ), 2*N+M )
+ $ M*N+4*MNMIN+MAX( M, N ), 2*N+M, LWTS )
*
DO 110 IRANK = 1, 2
DO 100 ISCALE = 1, 3
NRUN = NRUN + 2
30 CONTINUE
40 CONTINUE
+*
+*
+* Test CGETSLS
+*
+* Generate a matrix of scaling type ISCALE
+*
+ CALL CQRT13( ISCALE, M, N, COPYA, LDA, NORMA,
+ $ ISEED )
+ DO 65 INB = 1, NNB
+ MB = NBVAL( INB )
+ CALL XLAENV( 1, MB )
+ DO 62 IMB = 1, NNB
+ NB = NBVAL( IMB )
+ CALL XLAENV( 2, NB )
+*
+ DO 60 ITRAN = 1, 2
+ IF( ITRAN.EQ.1 ) THEN
+ TRANS = 'N'
+ NROWS = M
+ NCOLS = N
+ ELSE
+ TRANS = 'C'
+ NROWS = N
+ NCOLS = M
+ END IF
+ LDWORK = MAX( 1, NCOLS )
+*
+* Set up a consistent rhs
+*
+ IF( NCOLS.GT.0 ) THEN
+ CALL CLARNV( 2, ISEED, NCOLS*NRHS,
+ $ WORK )
+ CALL CSCAL( NCOLS*NRHS,
+ $ ONE / REAL( NCOLS ), WORK,
+ $ 1 )
+ END IF
+ CALL CGEMM( TRANS, 'No transpose', NROWS,
+ $ NRHS, NCOLS, CONE, COPYA, LDA,
+ $ WORK, LDWORK, CZERO, B, LDB )
+ CALL CLACPY( 'Full', NROWS, NRHS, B, LDB,
+ $ COPYB, LDB )
+*
+* Solve LS or overdetermined system
+*
+ IF( M.GT.0 .AND. N.GT.0 ) THEN
+ CALL CLACPY( 'Full', M, N, COPYA, LDA,
+ $ A, LDA )
+ CALL CLACPY( 'Full', NROWS, NRHS,
+ $ COPYB, LDB, B, LDB )
+ END IF
+ SRNAMT = 'DGETSLS '
+ CALL CGETSLS( TRANS, M, N, NRHS, A,
+ $ LDA, B, LDB, WORK, LWORK, INFO )
+ IF( INFO.NE.0 )
+ $ CALL ALAERH( PATH, 'CGETSLS ', INFO, 0,
+ $ TRANS, M, N, NRHS, -1, NB,
+ $ ITYPE, NFAIL, NERRS,
+ $ NOUT )
+*
+* Check correctness of results
+*
+ LDWORK = MAX( 1, NROWS )
+ IF( NROWS.GT.0 .AND. NRHS.GT.0 )
+ $ CALL CLACPY( 'Full', NROWS, NRHS,
+ $ COPYB, LDB, C, LDB )
+ CALL CQRT16( TRANS, M, N, NRHS, COPYA,
+ $ LDA, B, LDB, C, LDB, WORK,
+ $ RESULT( 15 ) )
+*
+ IF( ( ITRAN.EQ.1 .AND. M.GE.N ) .OR.
+ $ ( ITRAN.EQ.2 .AND. M.LT.N ) ) THEN
+*
+* Solving LS system
+*
+ RESULT( 16 ) = CQRT17( TRANS, 1, M, N,
+ $ NRHS, COPYA, LDA, B, LDB,
+ $ COPYB, LDB, C, WORK,
+ $ LWORK )
+ ELSE
+*
+* Solving overdetermined system
+*
+ RESULT( 16 ) = CQRT14( TRANS, M, N,
+ $ NRHS, COPYA, LDA, B, LDB,
+ $ WORK, LWORK )
+ END IF
+*
+* Print information about the tests that
+* did not pass the threshold.
+*
+ DO 50 K = 15, 16
+ IF( RESULT( K ).GE.THRESH ) THEN
+ IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
+ $ CALL ALAHD( NOUT, PATH )
+ WRITE( NOUT, FMT = 9997 )TRANS, M,
+ $ N, NRHS, MB, NB, ITYPE, K,
+ $ RESULT( K )
+ NFAIL = NFAIL + 1
+ END IF
+ 50 CONTINUE
+ NRUN = NRUN + 2
+ 60 CONTINUE
+ 62 CONTINUE
+ 65 CONTINUE
END IF
*
* Generate a matrix of scaling type ISCALE and rank
IF( RANK.GT.0 ) THEN
CALL SAXPY( MNMIN, -ONE, COPYS, 1, S, 1 )
RESULT( 7 ) = SASUM( MNMIN, S, 1 ) /
- $ SASUM( MNMIN, COPYS, 1 ) /
- $ ( EPS*REAL( MNMIN ) )
+ $ SASUM( MNMIN, COPYS, 1 ) /
+ $ ( EPS*REAL( MNMIN ) )
ELSE
RESULT( 7 ) = ZERO
END IF
RESULT( 9 ) = ZERO
IF( M.GT.CRANK )
$ RESULT( 9 ) = CQRT17( 'No transpose', 1, M,
- $ N, NRHS, COPYA, LDA, B, LDB,
- $ COPYB, LDB, C, WORK, LWORK )
+ $ N, NRHS, COPYA, LDA, B, LDB,
+ $ COPYB, LDB, C, WORK, LWORK )
*
* Test 10: Check if x is in the rowspace of A
*
* Print information about the tests that did not
* pass the threshold.
*
- DO 80 K = 3, NTESTS
+ DO 80 K = 3, 14
IF( RESULT( K ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
$ ', 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,
+ $ ', test(', I2, ')=', G12.5 )
RETURN
*
* End of CDRVLS
--- /dev/null
+*> \brief \b CERRLQT
+*
+* =========== DOCUMENTATION ===========
+*
+* 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:
+* =============
+*>
+*> \verbatim
+*>
+*> CERRLQT tests the error exits for the COMPLEX routines
+*> that use the LQT decomposition of a general matrix.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] PATH
+*> \verbatim
+*> PATH is CHARACTER*3
+*> The LAPACK path name for the routines to be tested.
+*> \endverbatim
+*>
+*> \param[in] NUNIT
+*> \verbatim
+*> NUNIT is INTEGER
+*> The unit number for output.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2011
+*
+*> \ingroup double_lin
+*
+* =====================================================================
+ SUBROUTINE CERRLQT( PATH, NUNIT )
+ IMPLICIT NONE
+*
+* -- LAPACK test routine (version 3.4.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2011
+*
+* .. Scalar Arguments ..
+ CHARACTER*3 PATH
+ INTEGER NUNIT
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER NMAX
+ PARAMETER ( NMAX = 2 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, INFO, J
+* ..
+* .. Local Arrays ..
+ COMPLEX A( NMAX, NMAX ), T( NMAX, NMAX ), W( NMAX ),
+ $ C( NMAX, NMAX )
+* ..
+* .. External Subroutines ..
+ EXTERNAL ALAESM, CHKXER, CGELQT3, CGELQT,
+ $ CGEMLQT
+* ..
+* .. Scalars in Common ..
+ LOGICAL LERR, OK
+ CHARACTER*32 SRNAMT
+ INTEGER INFOT, NOUT
+* ..
+* .. Common blocks ..
+ COMMON / INFOC / INFOT, NOUT, OK, LERR
+ COMMON / SRNAMC / SRNAMT
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC REAL, CMPLX
+* ..
+* .. Executable Statements ..
+*
+ NOUT = NUNIT
+ WRITE( NOUT, FMT = * )
+*
+* Set the variables to innocuous values.
+*
+ DO J = 1, NMAX
+ DO I = 1, NMAX
+ A( I, J ) = 1.E0 / CMPLX( REAL( I+J ), 0.E0 )
+ C( I, J ) = 1.E0 / CMPLX( REAL( I+J ), 0.E0 )
+ T( I, J ) = 1.E0 / CMPLX( REAL( I+J ), 0.E0 )
+ END DO
+ W( J ) = 0.E0
+ END DO
+ OK = .TRUE.
+*
+* Error exits for LQT factorization
+*
+* CGELQT
+*
+ SRNAMT = 'CGELQT'
+ INFOT = 1
+ CALL CGELQT( -1, 0, 1, A, 1, T, 1, W, INFO )
+ CALL CHKXER( 'CGELQT', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL CGELQT( 0, -1, 1, A, 1, T, 1, W, INFO )
+ CALL CHKXER( 'CGELQT', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL CGELQT( 0, 0, 0, A, 1, T, 1, W, INFO )
+ CALL CHKXER( 'CGELQT', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL CGELQT( 2, 1, 1, A, 1, T, 1, W, INFO )
+ CALL CHKXER( 'CGELQT', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL CGELQT( 2, 2, 2, A, 2, T, 1, W, INFO )
+ CALL CHKXER( 'CGELQT', INFOT, NOUT, LERR, OK )
+*
+* CGELQT3
+*
+ SRNAMT = 'CGELQT3'
+ INFOT = 1
+ CALL CGELQT3( -1, 0, A, 1, T, 1, INFO )
+ CALL CHKXER( 'CGELQT3', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL CGELQT3( 0, -1, A, 1, T, 1, INFO )
+ CALL CHKXER( 'CGELQT3', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL CGELQT3( 2, 2, A, 1, T, 1, INFO )
+ CALL CHKXER( 'CGELQT3', INFOT, NOUT, LERR, OK )
+ INFOT = 6
+ CALL CGELQT3( 2, 2, A, 2, T, 1, INFO )
+ CALL CHKXER( 'CGELQT3', INFOT, NOUT, LERR, OK )
+*
+* CGEMLQT
+*
+ SRNAMT = 'CGEMLQT'
+ INFOT = 1
+ CALL CGEMLQT( '/', 'N', 0, 0, 0, 1, A, 1, T, 1, C, 1, W, INFO )
+ CALL CHKXER( 'CGEMLQT', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL CGEMLQT( 'L', '/', 0, 0, 0, 1, A, 1, T, 1, C, 1, W, INFO )
+ CALL CHKXER( 'CGEMLQT', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL CGEMLQT( 'L', 'N', -1, 0, 0, 1, A, 1, T, 1, C, 1, W, INFO )
+ CALL CHKXER( 'CGEMLQT', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL CGEMLQT( 'L', 'N', 0, -1, 0, 1, A, 1, T, 1, C, 1, W, INFO )
+ CALL CHKXER( 'CGEMLQT', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL CGEMLQT( 'L', 'N', 0, 0, -1, 1, A, 1, T, 1, C, 1, W, INFO )
+ CALL CHKXER( 'CGEMLQT', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL CGEMLQT( 'R', 'N', 0, 0, -1, 1, A, 1, T, 1, C, 1, W, INFO )
+ CALL CHKXER( 'CGEMLQT', INFOT, NOUT, LERR, OK )
+ INFOT = 6
+ CALL CGEMLQT( 'L', 'N', 0, 0, 0, 0, A, 1, T, 1, C, 1, W, INFO )
+ CALL CHKXER( 'CGEMLQT', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL CGEMLQT( 'R', 'N', 2, 2, 2, 1, A, 1, T, 1, C, 1, W, INFO )
+ CALL CHKXER( 'CGEMLQT', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL CGEMLQT( 'L', 'N', 2, 2, 2, 1, A, 1, T, 1, C, 1, W, INFO )
+ CALL CHKXER( 'CGEMLQT', INFOT, NOUT, LERR, OK )
+ INFOT = 10
+ CALL CGEMLQT( 'R', 'N', 1, 1, 1, 1, A, 1, T, 0, C, 1, W, INFO )
+ CALL CHKXER( 'CGEMLQT', INFOT, NOUT, LERR, OK )
+ INFOT = 12
+ CALL CGEMLQT( 'L', 'N', 1, 1, 1, 1, A, 1, T, 1, C, 0, W, INFO )
+ CALL CHKXER( 'CGEMLQT', INFOT, NOUT, LERR, OK )
+*
+* Print a summary line.
+*
+ CALL ALAESM( PATH, OK, NOUT )
+*
+ RETURN
+*
+* End of CERRLQT
+*
+ END
--- /dev/null
+*> \brief \b ZERRLQTP
+*
+* =========== DOCUMENTATION ===========
+*
+* 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:
+* =============
+*>
+*> \verbatim
+*>
+*> CERRLQTP tests the error exits for the complex routines
+*> that use the LQT decomposition of a triangular-pentagonal matrix.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] PATH
+*> \verbatim
+*> PATH is CHARACTER*3
+*> The LAPACK path name for the routines to be tested.
+*> \endverbatim
+*>
+*> \param[in] NUNIT
+*> \verbatim
+*> NUNIT is INTEGER
+*> The unit number for output.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2011
+*
+*> \ingroup double_lin
+*
+* =====================================================================
+ SUBROUTINE CERRLQTP( PATH, NUNIT )
+ IMPLICIT NONE
+*
+* -- LAPACK test routine (version 3.4.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2011
+*
+* .. Scalar Arguments ..
+ CHARACTER*3 PATH
+ INTEGER NUNIT
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER NMAX
+ PARAMETER ( NMAX = 2 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, INFO, J
+* ..
+* .. Local Arrays ..
+ COMPLEX A( NMAX, NMAX ), T( NMAX, NMAX ), W( NMAX ),
+ $ B( NMAX, NMAX ), C( NMAX, NMAX )
+* ..
+* .. External Subroutines ..
+ EXTERNAL ALAESM, CHKXER, CTPLQT2, CTPLQT,
+ $ CTPMLQT
+* ..
+* .. Scalars in Common ..
+ LOGICAL LERR, OK
+ CHARACTER*32 SRNAMT
+ INTEGER INFOT, NOUT
+* ..
+* .. Common blocks ..
+ COMMON / INFOC / INFOT, NOUT, OK, LERR
+ COMMON / SRNAMC / SRNAMT
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC REAL, CMPLX
+* ..
+* .. Executable Statements ..
+*
+ NOUT = NUNIT
+ WRITE( NOUT, FMT = * )
+*
+* Set the variables to innocuous values.
+*
+ DO J = 1, NMAX
+ DO I = 1, NMAX
+ A( I, J ) = 1.E0 / CMPLX( REAL( I+J ), 0.E0 )
+ C( I, J ) = 1.E0 / CMPLX( REAL( I+J ), 0.E0 )
+ T( I, J ) = 1.E0 / CMPLX( REAL( I+J ), 0.E0 )
+ END DO
+ W( J ) = 0.E0
+ END DO
+ OK = .TRUE.
+*
+* Error exits for TPLQT factorization
+*
+* CTPLQT
+*
+ SRNAMT = 'CTPLQT'
+ INFOT = 1
+ CALL CTPLQT( -1, 1, 0, 1, A, 1, B, 1, T, 1, W, INFO )
+ CALL CHKXER( 'CTPLQT', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL CTPLQT( 1, -1, 0, 1, A, 1, B, 1, T, 1, W, INFO )
+ CALL CHKXER( 'CTPLQT', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL CTPLQT( 0, 1, -1, 1, A, 1, B, 1, T, 1, W, INFO )
+ CALL CHKXER( 'CTPLQT', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL CTPLQT( 0, 1, 1, 1, A, 1, B, 1, T, 1, W, INFO )
+ CALL CHKXER( 'CTPLQT', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL CTPLQT( 0, 1, 0, 0, A, 1, B, 1, T, 1, W, INFO )
+ CALL CHKXER( 'CTPLQT', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL CTPLQT( 1, 1, 0, 2, A, 1, B, 1, T, 1, W, INFO )
+ CALL CHKXER( 'CTPLQT', INFOT, NOUT, LERR, OK )
+ INFOT = 6
+ CALL CTPLQT( 2, 1, 0, 2, A, 1, B, 1, T, 1, W, INFO )
+ CALL CHKXER( 'CTPLQT', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL CTPLQT( 2, 1, 0, 1, A, 2, B, 1, T, 1, W, INFO )
+ CALL CHKXER( 'CTPLQT', INFOT, NOUT, LERR, OK )
+ INFOT = 10
+ CALL CTPLQT( 2, 2, 1, 2, A, 2, B, 2, T, 1, W, INFO )
+ CALL CHKXER( 'CTPLQT', INFOT, NOUT, LERR, OK )
+*
+* CTPLQT2
+*
+ SRNAMT = 'CTPLQT2'
+ INFOT = 1
+ CALL CTPLQT2( -1, 0, 0, A, 1, B, 1, T, 1, INFO )
+ CALL CHKXER( 'CTPLQT2', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL CTPLQT2( 0, -1, 0, A, 1, B, 1, T, 1, INFO )
+ CALL CHKXER( 'CTPLQT2', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL CTPLQT2( 0, 0, -1, A, 1, B, 1, T, 1, INFO )
+ CALL CHKXER( 'CTPLQT2', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL CTPLQT2( 2, 2, 0, A, 1, B, 2, T, 2, INFO )
+ CALL CHKXER( 'CTPLQT2', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL CTPLQT2( 2, 2, 0, A, 2, B, 1, T, 2, INFO )
+ CALL CHKXER( 'CTPLQT2', INFOT, NOUT, LERR, OK )
+ INFOT = 9
+ CALL CTPLQT2( 2, 2, 0, A, 2, B, 2, T, 1, INFO )
+ CALL CHKXER( 'CTPLQT2', INFOT, NOUT, LERR, OK )
+*
+* CTPMLQT
+*
+ SRNAMT = 'CTPMLQT'
+ INFOT = 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,
+ $ 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,
+ $ 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,
+ $ 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,
+ $ W, INFO )
+ INFOT = 6
+ 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,
+ $ 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,
+ $ 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,
+ $ 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,
+ $ 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,
+ $ W, INFO )
+ CALL CHKXER( 'CTPMLQT', INFOT, NOUT, LERR, OK )
+*
+* Print a summary line.
+*
+ CALL ALAESM( PATH, OK, NOUT )
+*
+ RETURN
+*
+* End of CERRLQT
+*
+ END
--- /dev/null
+*> \brief \b CERRTSQR
+*
+* =========== DOCUMENTATION ===========
+*
+* 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:
+* =============
+*>
+*> \verbatim
+*>
+*> CERRTSQR tests the error exits for the COMPLEX routines
+*> that use the TSQR decomposition of a general matrix.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] PATH
+*> \verbatim
+*> PATH is CHARACTER*3
+*> The LAPACK path name for the routines to be tested.
+*> \endverbatim
+*>
+*> \param[in] NUNIT
+*> \verbatim
+*> NUNIT is INTEGER
+*> The unit number for output.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Zenver
+*> \author NAG Ltd.
+*
+*> \date November 2011
+*
+*> \ingroup double_lin
+*
+* =====================================================================
+ SUBROUTINE CERRTSQR( PATH, NUNIT )
+ IMPLICIT NONE
+*
+* -- LAPACK test routine (version 3.4.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2011
+*
+* .. Scalar Arguments ..
+ CHARACTER*3 PATH
+ INTEGER NUNIT
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER NMAX
+ PARAMETER ( NMAX = 2 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, INFO, J, NB
+* ..
+* .. Local Arrays ..
+ COMPLEX A( NMAX, NMAX ), T( NMAX, NMAX ), W( NMAX ),
+ $ C( NMAX, NMAX ), TAU(NMAX)
+* ..
+* .. External Subroutines ..
+ EXTERNAL ALAESM, CHKXER, CGEQR,
+ $ CGEMQR, CGELQ, CGEMLQ
+* ..
+* .. Scalars in Common ..
+ LOGICAL LERR, OK
+ CHARACTER*32 SRNAMT
+ INTEGER INFOT, NOUT
+* ..
+* .. Common blocks ..
+ COMMON / INFOC / INFOT, NOUT, OK, LERR
+ COMMON / SRNAMC / SRNAMT
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC REAL
+* ..
+* .. Executable Statements ..
+*
+ NOUT = NUNIT
+ WRITE( NOUT, FMT = * )
+*
+* Set the variables to innocuous values.
+*
+ DO J = 1, NMAX
+ DO I = 1, NMAX
+ A( I, J ) = 1.E0 / CMPLX( REAL( I+J ), 0.E0 )
+ C( I, J ) = 1.E0 / CMPLX( REAL( I+J ), 0.E0 )
+ T( I, J ) = 1.E0 / CMPLX( REAL( I+J ), 0.E0 )
+ END DO
+ W( J ) = 0.E0
+ END DO
+ OK = .TRUE.
+*
+* Error exits for TS factorization
+*
+* CGEQR
+*
+ SRNAMT = 'CGEQR'
+ INFOT = 1
+ CALL CGEQR( -1, 0, A, 1, TAU, 1, W, 1, INFO )
+ CALL CHKXER( 'CGEQR', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL CGEQR( 0, -1, A, 1, TAU, 1, W, 1, INFO )
+ CALL CHKXER( 'CGEQR', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL CGEQR( 1, 1, A, 0, TAU, 1, W, 1, INFO )
+ CALL CHKXER( 'CGEQR', INFOT, NOUT, LERR, OK )
+ INFOT = 6
+ CALL CGEQR( 3, 2, A, 3, TAU, 1, W, 1, INFO )
+ CALL CHKXER( 'CGEQR', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL CGEQR( 3, 2, A, 3, TAU, 8, W, 0, INFO )
+ CALL CHKXER( 'CGEQR', INFOT, NOUT, LERR, OK )
+*
+* CGEMQR
+*
+ TAU(1)=1
+ TAU(2)=1
+ SRNAMT = 'CGEMQR'
+ NB=1
+ INFOT = 1
+ CALL CGEMQR( '/', 'N', 0, 0, 0, A, 1, TAU, 1, C, 1, W, 1,INFO)
+ CALL CHKXER( 'CGEMQR', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL CGEMQR( 'L', '/', 0, 0, 0, A, 1, TAU, 1, C, 1, W, 1,INFO)
+ CALL CHKXER( 'CGEMQR', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL CGEMQR( 'L', 'N', -1, 0, 0, A, 1, TAU, 1, C, 1, W,1,INFO)
+ CALL CHKXER( 'CGEMQR', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL CGEMQR( 'L', 'N', 0, -1, 0, A, 1, TAU, 1, C, 1, W,1,INFO)
+ CALL CHKXER( 'CGEMQR', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL CGEMQR( 'L', 'N', 0, 0, -1, A, 1, TAU, 1, C, 1, W,1,INFO)
+ CALL CHKXER( 'CGEMQR', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL CGEMQR( 'R', 'N', 0, 0, -1, A, 1, TAU, 1, C, 1, W,1,INFO)
+ CALL CHKXER( 'CGEMQR', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL CGEMQR( 'L', 'N', 2, 1, 0, A, 0, TAU, 1, C, 1, W, 1,INFO)
+ CALL CHKXER( 'CGEMQR', INFOT, NOUT, LERR, OK )
+ INFOT = 9
+ CALL CGEMQR( 'R', 'N', 2, 2, 1, A, 1, TAU, 0, C, 1, W, 1,INFO)
+ CALL CHKXER( 'CGEMQR', INFOT, NOUT, LERR, OK )
+ INFOT = 9
+ CALL CGEMQR( 'L', 'N', 2, 2, 1, A, 1, TAU, 0, C, 1, W, 1,INFO)
+ CALL CHKXER( 'CGEMQR', INFOT, NOUT, LERR, OK )
+ INFOT = 11
+ CALL CGEMQR( 'L', 'N', 2, 1, 1, A, 1, TAU, 6, C, 0, W, 1,INFO)
+ CALL CHKXER( 'CGEMQR', INFOT, NOUT, LERR, OK )
+ INFOT = 13
+ CALL CGEMQR( 'L', 'N', 2, 2, 1, A, 2, TAU, 6, C, 2, W, 0,INFO)
+ CALL CHKXER( 'CGEMQR', INFOT, NOUT, LERR, OK )
+*
+* CGELQ
+*
+ SRNAMT = 'CGELQ'
+ INFOT = 1
+ CALL CGELQ( -1, 0, A, 1, TAU, 1, W, 1, INFO )
+ CALL CHKXER( 'CGELQ', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL CGELQ( 0, -1, A, 1, TAU, 1, W, 1, INFO )
+ CALL CHKXER( 'CGELQ', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL CGELQ( 1, 1, A, 0, TAU, 1, W, 1, INFO )
+ CALL CHKXER( 'CGELQ', INFOT, NOUT, LERR, OK )
+ INFOT = 6
+ CALL CGELQ( 2, 3, A, 3, TAU, 1, W, 1, INFO )
+ CALL CHKXER( 'CGELQ', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL CGELQ( 2, 3, A, 3, TAU, 8, W, 0, INFO )
+ CALL CHKXER( 'CGELQ', INFOT, NOUT, LERR, OK )
+*
+* CGEMLQ
+*
+ TAU(1)=1
+ TAU(2)=1
+ SRNAMT = 'CGEMLQ'
+ NB=1
+ INFOT = 1
+ CALL CGEMLQ( '/', 'N', 0, 0, 0, A, 1, TAU, 1, C, 1, W, 1,INFO)
+ CALL CHKXER( 'CGEMLQ', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL CGEMLQ( 'L', '/', 0, 0, 0, A, 1, TAU, 1, C, 1, W, 1,INFO)
+ CALL CHKXER( 'CGEMLQ', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL CGEMLQ( 'L', 'N', -1, 0, 0, A, 1, TAU, 1, C, 1, W,1,INFO)
+ CALL CHKXER( 'CGEMLQ', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL CGEMLQ( 'L', 'N', 0, -1, 0, A, 1, TAU, 1, C, 1, W,1,INFO)
+ CALL CHKXER( 'CGEMLQ', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL CGEMLQ( 'L', 'N', 0, 0, -1, A, 1, TAU, 1, C, 1, W,1,INFO)
+ CALL CHKXER( 'CGEMLQ', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL CGEMLQ( 'R', 'N', 0, 0, -1, A, 1, TAU, 1, C, 1, W,1,INFO)
+ CALL CHKXER( 'CGEMLQ', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL CGEMLQ( 'L', 'N', 1, 2, 0, A, 0, TAU, 1, C, 1, W, 1,INFO)
+ CALL CHKXER( 'CGEMLQ', INFOT, NOUT, LERR, OK )
+ INFOT = 9
+ CALL CGEMLQ( 'R', 'N', 2, 2, 1, A, 1, TAU, 0, C, 1, W, 1,INFO)
+ CALL CHKXER( 'CGEMLQ', INFOT, NOUT, LERR, OK )
+ INFOT = 9
+ CALL CGEMLQ( 'L', 'N', 2, 2, 1, A, 1, TAU, 0, C, 1, W, 1,INFO)
+ CALL CHKXER( 'CGEMLQ', INFOT, NOUT, LERR, OK )
+ INFOT = 11
+ CALL CGEMLQ( 'L', 'N', 1, 2, 1, A, 1, TAU, 6, C, 0, W, 1,INFO)
+ CALL CHKXER( 'CGEMLQ', INFOT, NOUT, LERR, OK )
+ INFOT = 13
+ CALL CGEMLQ( 'L', 'N', 2, 2, 1, A, 2, TAU, 6, C, 2, W, 0,INFO)
+ CALL CHKXER( 'CGEMLQ', INFOT, NOUT, LERR, OK )
+*
+* Print a summary line.
+*
+ CALL ALAESM( PATH, OK, NOUT )
+*
+ RETURN
+*
+* End of CERRTSQR
+*
+ END
--- /dev/null
+*> \brief \b DLQT04
+*
+* =========== DOCUMENTATION ===========
+*
+* 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:
+* =============
+*>
+*> \verbatim
+*>
+*> CLQT04 tests CGELQT and CGEMLQT.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> Number of rows in test matrix.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> Number of columns in test matrix.
+*> \endverbatim
+*>
+*> \param[in] NB
+*> \verbatim
+*> NB is INTEGER
+*> Block size of test matrix. NB <= Min(M,N).
+*> \endverbatim
+*>
+*> \param[out] RESULT
+*> \verbatim
+*> RESULT is DOUBLE PRECISION array, dimension (6)
+*> Results of each of the six tests below.
+*>
+*> RESULT(1) = | A - L Q |
+*> 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(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.
+*
+*> \date April 2012
+*
+*> \ingroup double_lin
+*
+* =====================================================================
+ SUBROUTINE CLQT04(M,N,NB,RESULT)
+ IMPLICIT NONE
+*
+* -- LAPACK test routine (version 3.4.1) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* April 2012
+*
+* .. Scalar Arguments ..
+ INTEGER M, N, NB
+* .. Return values ..
+ REAL RESULT(6)
+*
+* =====================================================================
+*
+* ..
+* .. Local allocatable arrays
+ COMPLEX, ALLOCATABLE :: AF(:,:), Q(:,:),
+ $ L(:,:), RWORK(:), WORK( : ), T(:,:),
+ $ CF(:,:), DF(:,:), A(:,:), C(:,:), D(:,:)
+*
+* .. Parameters ..
+ REAL ZERO
+ COMPLEX ONE, CZERO
+ PARAMETER( ZERO = 0.0)
+ PARAMETER( ONE = (1.0,0.0), CZERO=(0.0,0.0) )
+* ..
+* .. Local Scalars ..
+ INTEGER INFO, J, K, LL, LWORK, LDT
+ REAL ANORM, EPS, RESID, CNORM, DNORM
+* ..
+* .. Local Arrays ..
+ INTEGER ISEED( 4 )
+* ..
+* .. External Functions ..
+ REAL SLAMCH
+ REAL CLANGE, CLANSY
+ LOGICAL LSAME
+ EXTERNAL SLAMCH, CLANGE, CLANSY, LSAME
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Data statements ..
+ DATA ISEED / 1988, 1989, 1990, 1991 /
+*
+ EPS = SLAMCH( 'Epsilon' )
+ K = MIN(M,N)
+ LL = MAX(M,N)
+ LWORK = MAX(2,LL)*MAX(2,LL)*NB
+*
+* 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),
+ $ D(N,M), DF(N,M) )
+*
+* Put random numbers into A and copy to AF
+*
+ LDT=NB
+ DO J=1,N
+ CALL CLARNV( 2, ISEED, M, A( 1, J ) )
+ END DO
+ CALL CLACPY( 'Full', M, N, A, M, AF, M )
+*
+* Factor the matrix A in the array AF.
+*
+ CALL CGELQT( M, N, NB, AF, M, T, LDT, WORK, INFO )
+*
+* 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,
+ $ WORK, INFO )
+*
+* Copy L
+*
+ CALL CLASET( 'Full', LL, N, CZERO, CZERO, L, LL )
+ CALL CLACPY( 'Lower', M, N, AF, M, L, LL )
+*
+* Compute |L - A*Q'| / |A| and store in RESULT(1)
+*
+ CALL CGEMM( 'N', 'C', M, N, N, -ONE, A, M, Q, N, ONE, L, LL )
+ ANORM = CLANGE( '1', M, N, A, M, RWORK )
+ RESID = CLANGE( '1', M, N, L, LL, RWORK )
+ IF( ANORM.GT.ZERO ) THEN
+ RESULT( 1 ) = RESID / (EPS*MAX(1,M)*ANORM)
+ ELSE
+ RESULT( 1 ) = ZERO
+ END IF
+*
+* Compute |I - Q'*Q| and store in RESULT(2)
+*
+ CALL CLASET( 'Full', N, N, CZERO, ONE, L, LL )
+ CALL CHERK( 'U', 'C', N, N, REAL(-ONE), Q, N, REAL(ONE), L, LL)
+ RESID = CLANSY( '1', 'Upper', N, L, LL, RWORK )
+ RESULT( 2 ) = RESID / (EPS*MAX(1,N))
+*
+* Generate random m-by-n matrix C and a copy CF
+*
+ DO J=1,M
+ CALL CLARNV( 2, ISEED, N, D( 1, J ) )
+ END DO
+ DNORM = CLANGE( '1', N, M, D, N, RWORK)
+ CALL CLACPY( 'Full', N, M, D, N, DF, N )
+*
+* Apply Q to C as Q*C
+*
+ CALL CGEMLQT( 'L', 'N', N, M, K, NB, AF, M, T, NB, DF, N,
+ $ WORK, INFO)
+*
+* Compute |Q*D - Q*D| / |D|
+*
+ CALL CGEMM( 'N', 'N', N, M, N, -ONE, Q, N, D, N, ONE, DF, N )
+ RESID = CLANGE( '1', N, M, DF, N, RWORK )
+ IF( DNORM.GT.ZERO ) THEN
+ RESULT( 3 ) = RESID / (EPS*MAX(1,M)*DNORM)
+ ELSE
+ RESULT( 3 ) = ZERO
+ END IF
+*
+* Copy D into DF again
+*
+ CALL CLACPY( 'Full', N, M, D, N, DF, N )
+*
+* Apply Q to D as QT*D
+*
+ CALL CGEMLQT( 'L', 'C', N, M, K, NB, AF, M, T, NB, DF, N,
+ $ WORK, INFO)
+*
+* Compute |QT*D - QT*D| / |D|
+*
+ CALL CGEMM( 'C', 'N', N, M, N, -ONE, Q, N, D, N, ONE, DF, N )
+ RESID = CLANGE( '1', N, M, DF, N, RWORK )
+ IF( DNORM.GT.ZERO ) THEN
+ RESULT( 4 ) = RESID / (EPS*MAX(1,M)*DNORM)
+ ELSE
+ RESULT( 4 ) = ZERO
+ END IF
+*
+* Generate random n-by-m matrix D and a copy DF
+*
+ DO J=1,N
+ CALL CLARNV( 2, ISEED, M, C( 1, J ) )
+ END DO
+ CNORM = CLANGE( '1', M, N, C, M, RWORK)
+ CALL CLACPY( 'Full', M, N, C, M, CF, M )
+*
+* Apply Q to C as C*Q
+*
+ CALL CGEMLQT( 'R', 'N', M, N, K, NB, AF, M, T, NB, CF, M,
+ $ WORK, INFO)
+*
+* Compute |C*Q - C*Q| / |C|
+*
+ CALL CGEMM( 'N', 'N', M, N, N, -ONE, C, M, Q, N, ONE, CF, M )
+ RESID = CLANGE( '1', N, M, DF, N, RWORK )
+ IF( CNORM.GT.ZERO ) THEN
+ RESULT( 5 ) = RESID / (EPS*MAX(1,M)*DNORM)
+ ELSE
+ RESULT( 5 ) = ZERO
+ END IF
+*
+* Copy C into CF again
+*
+ CALL CLACPY( 'Full', M, N, C, M, CF, M )
+*
+* Apply Q to D as D*QT
+*
+ CALL CGEMLQT( 'R', 'C', M, N, K, NB, AF, M, T, NB, CF, M,
+ $ WORK, INFO)
+*
+* Compute |C*QT - C*QT| / |C|
+*
+ CALL CGEMM( 'N', 'C', M, N, N, -ONE, C, M, Q, N, ONE, CF, M )
+ RESID = CLANGE( '1', M, N, CF, M, RWORK )
+ IF( CNORM.GT.ZERO ) THEN
+ RESULT( 6 ) = RESID / (EPS*MAX(1,M)*DNORM)
+ ELSE
+ RESULT( 6 ) = ZERO
+ END IF
+*
+* Deallocate all arrays
+*
+ DEALLOCATE ( A, AF, Q, L, RWORK, WORK, T, C, D, CF, DF)
+*
+ RETURN
+ END
+
--- /dev/null
+*> \brief \b CLQT05
+*
+* =========== DOCUMENTATION ===========
+*
+* 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:
+* =============
+*>
+*> \verbatim
+*>
+*> CQRT05 tests CTPLQT and CTPMLQT.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> Number of rows in lower part of the test matrix.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> Number of columns in test matrix.
+*> \endverbatim
+*>
+*> \param[in] L
+*> \verbatim
+*> L is INTEGER
+*> The number of rows of the upper trapezoidal part the
+*> lower test matrix. 0 <= L <= M.
+*> \endverbatim
+*>
+*> \param[in] NB
+*> \verbatim
+*> NB is INTEGER
+*> Block size of test matrix. NB <= N.
+*> \endverbatim
+*>
+*> \param[out] RESULT
+*> \verbatim
+*> RESULT is DOUBLE PRECISION array, dimension (6)
+*> Results of each of the six tests below.
+*>
+*> RESULT(1) = | A - Q R |
+*> 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(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.
+*
+*> \date April 2012
+*
+*> \ingroup double_lin
+*
+* =====================================================================
+ SUBROUTINE CLQT05(M,N,L,NB,RESULT)
+ IMPLICIT NONE
+*
+* -- LAPACK test routine (version 3.4.1) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* April 2012
+*
+* .. Scalar Arguments ..
+ INTEGER LWORK, M, N, L, NB, LDT
+* .. Return values ..
+ REAL RESULT(6)
+*
+* =====================================================================
+*
+* ..
+* .. Local allocatable arrays
+ COMPLEX, ALLOCATABLE :: AF(:,:), Q(:,:),
+ $ R(:,:), RWORK(:), WORK( : ), T(:,:),
+ $ CF(:,:), DF(:,:), A(:,:), C(:,:), D(:,:)
+*
+* .. Parameters ..
+ REAL ZERO
+ COMPLEX ONE, CZERO
+ PARAMETER( ZERO = 0.0, ONE = (1.0,0.0), CZERO=(0.0,0.0) )
+* ..
+* .. Local Scalars ..
+ INTEGER INFO, J, K, N2, NP1,i
+ REAL ANORM, EPS, RESID, CNORM, DNORM
+* ..
+* .. Local Arrays ..
+ INTEGER ISEED( 4 )
+* ..
+* .. External Functions ..
+ REAL SLAMCH
+ REAL CLANGE, CLANSY
+ LOGICAL LSAME
+ EXTERNAL SLAMCH, CLANGE, CLANSY, LSAME
+* ..
+* .. Data statements ..
+ DATA ISEED / 1988, 1989, 1990, 1991 /
+*
+ EPS = SLAMCH( 'Epsilon' )
+ K = M
+ N2 = M+N
+ IF( N.GT.0 ) THEN
+ NP1 = M+1
+ ELSE
+ NP1 = 1
+ END IF
+ LWORK = N2*N2*NB
+*
+* 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),
+ $ D(M,N2),DF(M,N2) )
+*
+* Put random stuff into A
+*
+ LDT=NB
+ CALL CLASET( 'Full', M, N2, CZERO, CZERO, A, M )
+ CALL CLASET( 'Full', NB, M, CZERO, CZERO, T, NB )
+ DO J=1,M
+ CALL CLARNV( 2, ISEED, M-J+1, A( J, J ) )
+ END DO
+ IF( N.GT.0 ) THEN
+ DO J=1,N-L
+ CALL CLARNV( 2, ISEED, M, A( 1, MIN(N+M,M+1) + J - 1 ) )
+ END DO
+ 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)
+ $ + J - 1 ) )
+ END DO
+ END IF
+*
+* Copy the matrix A to the array AF.
+*
+ CALL CLACPY( 'Full', M, N2, A, M, AF, M )
+*
+* Factor the matrix A in the array AF.
+*
+ CALL CTPLQT( M,N,L,NB,AF,M,AF(1,NP1),M,T,LDT,WORK,INFO)
+*
+* Generate the (M+N)-by-(M+N) matrix Q by applying H to I
+*
+ CALL CLASET( 'Full', N2, N2, CZERO, ONE, Q, N2 )
+ CALL CGEMLQT( 'L', 'N', N2, N2, K, NB, AF, M, T, LDT, Q, N2,
+ $ WORK, INFO )
+*
+* Copy L
+*
+ CALL CLASET( 'Full', N2, N2, CZERO, CZERO, R, N2 )
+ CALL CLACPY( 'Lower', M, N2, AF, M, R, N2 )
+*
+* Compute |L - A*Q*C| / |A| and store in RESULT(1)
+*
+ CALL CGEMM( 'N', 'C', M, N2, N2, -ONE, A, M, Q, N2, ONE, R, N2)
+ ANORM = CLANGE( '1', M, N2, A, M, RWORK )
+ RESID = CLANGE( '1', M, N2, R, N2, RWORK )
+ IF( ANORM.GT.ZERO ) THEN
+ RESULT( 1 ) = RESID / (EPS*ANORM*MAX(1,N2))
+ ELSE
+ RESULT( 1 ) = ZERO
+ END IF
+*
+* Compute |I - Q*Q'| and store in RESULT(2)
+*
+ CALL CLASET( 'Full', N2, N2, CZERO, ONE, R, N2 )
+ CALL CHERK( 'U', 'N', N2, N2, REAL(-ONE), Q, N2, REAL(ONE),
+ $ R, N2 )
+ RESID = CLANSY( '1', 'Upper', N2, R, N2, RWORK )
+ RESULT( 2 ) = RESID / (EPS*MAX(1,N2))
+*
+* Generate random m-by-n matrix C and a copy CF
+*
+ CALL CLASET( 'Full', N2, M, CZERO, ONE, C, N2 )
+ DO J=1,M
+ CALL CLARNV( 2, ISEED, N2, C( 1, J ) )
+ END DO
+ CNORM = CLANGE( '1', N2, M, C, N2, RWORK)
+ 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)
+*
+* Compute |Q*C - Q*C| / |C|
+*
+ CALL CGEMM( 'N', '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( 3 ) = RESID / (EPS*MAX(1,N2)*CNORM)
+ ELSE
+ RESULT( 3 ) = ZERO
+ END IF
+
+*
+* Copy C into CF again
+*
+ CALL CLACPY( 'Full', N2, M, C, N2, CF, N2 )
+*
+* 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)
+*
+* 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
+*
+* Generate random m-by-n matrix D and a copy DF
+*
+ DO J=1,N2
+ CALL CLARNV( 2, ISEED, M, D( 1, J ) )
+ END DO
+ DNORM = CLANGE( '1', M, N2, D, M, RWORK)
+ CALL CLACPY( 'Full', M, N2, D, M, DF, M )
+*
+* Apply Q to D as D*Q
+*
+ CALL CTPMLQT('R','N',M,N,K,L,NB,AF(1,NP1),M,T,LDT,DF,M,
+ $ DF(1,NP1),M,WORK,INFO)
+*
+* Compute |D*Q - D*Q| / |D|
+*
+ CALL CGEMM('N','N',M,N2,N2,-ONE,D,M,Q,N2,ONE,DF,M)
+ RESID = CLANGE('1',M, N2,DF,M,RWORK )
+ IF( CNORM.GT.ZERO ) THEN
+ RESULT( 5 ) = RESID / (EPS*MAX(1,N2)*DNORM)
+ ELSE
+ RESULT( 5 ) = ZERO
+ END IF
+*
+* Copy D into DF again
+*
+ CALL CLACPY('Full',M,N2,D,M,DF,M )
+*
+* 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)
+
+*
+* Compute |D*QT - D*QT| / |D|
+*
+ CALL CGEMM( 'N', 'C', M, N2, N2, -ONE, D, M, Q, N2, ONE, DF, M )
+ RESID = CLANGE( '1', M, N2, DF, M, RWORK )
+ IF( CNORM.GT.ZERO ) THEN
+ RESULT( 6 ) = RESID / (EPS*MAX(1,N2)*DNORM)
+ ELSE
+ RESULT( 6 ) = ZERO
+ END IF
+*
+* Deallocate all arrays
+*
+ DEALLOCATE ( A, AF, Q, R, RWORK, WORK, T, C, D, CF, DF)
+ RETURN
+ END
\ No newline at end of file
--- /dev/null
+*> \brief \b CTSQR01
+*
+* =========== DOCUMENTATION ===========
+*
+* 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:
+* =============
+*>
+*> \verbatim
+*>
+*> DTSQR01 tests DGEQR , DGELQ, DGEMLQ and DGEMQR.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] TSSW
+*> \verbatim
+*> TSSW is CHARACTER
+*> 'TS' for testing tall skinny QR
+*> and anything else for testing short wide LQ
+*> \endverbatim
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> Number of rows in test matrix.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> Number of columns in test matrix.
+*> \endverbatim
+*> \param[in] MB
+*> \verbatim
+*> MB is INTEGER
+*> Number of row in row block in test matrix.
+*> \endverbatim
+*>
+*> \param[in] NB
+*> \verbatim
+*> NB is INTEGER
+*> Number of columns in column block test matrix.
+*> \endverbatim
+*>
+*> \param[out] RESULT
+*> \verbatim
+*> RESULT is REAL array, dimension (6)
+*> Results of each of the six tests below.
+*>
+*> RESULT(1) = | A - Q R | or | A - L Q |
+*> 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(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.
+*
+*> \date April 2012
+*
+* =====================================================================
+ SUBROUTINE CTSQR01(TSSW, M, N, MB, NB, RESULT)
+ IMPLICIT NONE
+*
+* -- LAPACK test routine (version 3.4.1) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* April 2012
+*
+* .. Scalar Arguments ..
+ CHARACTER TSSW
+ INTEGER M, N, MB, NB
+* .. Return values ..
+ REAL RESULT(6)
+*
+* =====================================================================
+*
+* ..
+* .. Local allocatable arrays
+ COMPLEX, ALLOCATABLE :: AF(:,:), Q(:,:),
+ $ R(:,:), RWORK(:), WORK( : ), T(:),
+ $ CF(:,:), DF(:,:), A(:,:), C(:,:), D(:,:), LQ(:,:)
+*
+* .. Parameters ..
+ REAL ZERO
+ COMPLEX ONE, CZERO
+ PARAMETER( ZERO = 0.0, ONE = (1.0,0.0), CZERO=(0.0,0.0) )
+* ..
+* .. Local Scalars ..
+ LOGICAL TESTZEROS, TS
+ INTEGER INFO, J, K, L, LWORK, LT ,MNB
+ REAL ANORM, EPS, RESID, CNORM, DNORM
+* ..
+* .. Local Arrays ..
+ INTEGER ISEED( 4 )
+* ..
+* .. External Functions ..
+ REAL SLAMCH, CLANGE, CLANSY
+ LOGICAL LSAME
+ INTEGER ILAENV
+ EXTERNAL SLAMCH, CLANGE, CLANSY, LSAME, ILAENV
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* .. Scalars in Common ..
+ CHARACTER*32 srnamt
+* ..
+* .. Common blocks ..
+ COMMON / srnamc / srnamt
+* ..
+* .. Data statements ..
+ 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 = SLAMCH( 'Epsilon' )
+ K = MIN(M,N)
+ L = MAX(M,N,1)
+ MNB = MAX ( MB, NB)
+ LWORK = MAX(3,L)*MNB
+ 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
+ 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),
+ $ D(N,M), DF(N,M), LQ(L,N) )
+*
+* Put random numbers into A and copy to AF
+*
+ DO J=1,N
+ CALL CLARNV( 2, ISEED, M, A( 1, J ) )
+ END DO
+ IF (TESTZEROS) THEN
+ IF (M.GE.4) THEN
+ DO J=1,N
+ CALL CLARNV( 2, ISEED, M/2, A( M/4, J ) )
+ END DO
+ END IF
+ END IF
+ CALL CLACPY( 'Full', M, N, A, M, AF, M )
+*
+ IF (TS) THEN
+*
+* Factor the matrix A in the array AF.
+*
+ srnamt = 'CGEQR'
+ CALL CGEQR( M, N, AF, M, T, LT, WORK, LWORK, INFO )
+*
+* Generate the m-by-m matrix Q
+*
+ CALL CLASET( 'Full', M, M, CZERO, ONE, Q, M )
+ srnamt = 'CGEMQR'
+ CALL CGEMQR( 'L', 'N', M, M, K, AF, M, T, LT, Q, M,
+ $ WORK, LWORK, INFO )
+*
+* Copy R
+*
+ CALL CLASET( 'Full', M, N, CZERO, CZERO, R, M )
+ CALL CLACPY( 'Upper', M, N, AF, M, R, M )
+*
+* Compute |R - Q'*A| / |A| and store in RESULT(1)
+*
+ CALL CGEMM( 'C', 'N', M, N, M, -ONE, Q, M, A, M, ONE, R, M )
+ ANORM = CLANGE( '1', M, N, A, M, RWORK )
+ RESID = CLANGE( '1', M, N, R, M, RWORK )
+ IF( ANORM.GT.ZERO ) THEN
+ RESULT( 1 ) = RESID / (EPS*MAX(1,M)*ANORM)
+ ELSE
+ RESULT( 1 ) = ZERO
+ END IF
+*
+* Compute |I - Q'*Q| and store in RESULT(2)
+*
+ CALL CLASET( 'Full', M, M, CZERO, ONE, R, M )
+ CALL CHERK( 'U', 'C', M, M, REAL(-ONE), Q, M, REAL(ONE), R, M )
+ RESID = CLANSY( '1', 'Upper', M, R, M, RWORK )
+ RESULT( 2 ) = RESID / (EPS*MAX(1,M))
+*
+* Generate random m-by-n matrix C and a copy CF
+*
+ DO J=1,N
+ CALL CLARNV( 2, ISEED, M, C( 1, J ) )
+ END DO
+ CNORM = CLANGE( '1', M, N, C, M, RWORK)
+ CALL CLACPY( 'Full', M, N, C, M, CF, M )
+*
+* Apply Q to C as Q*C
+*
+ srnamt = 'CGEMQR'
+ CALL CGEMQR( 'L', 'N', M, N, K, AF, M, T, LT, CF, M,
+ $ WORK, LWORK, INFO)
+*
+* Compute |Q*C - Q*C| / |C|
+*
+ CALL CGEMM( 'N', 'N', M, N, M, -ONE, Q, M, C, M, ONE, CF, M )
+ RESID = CLANGE( '1', M, N, CF, M, RWORK )
+ IF( CNORM.GT.ZERO ) THEN
+ RESULT( 3 ) = RESID / (EPS*MAX(1,M)*CNORM)
+ ELSE
+ RESULT( 3 ) = ZERO
+ END IF
+*
+* Copy C into CF again
+*
+ CALL CLACPY( 'Full', M, N, C, M, CF, M )
+*
+* Apply Q to C as QT*C
+*
+ srnamt = 'CGEMQR'
+ CALL CGEMQR( 'L', 'C', M, N, K, AF, M, T, LT, CF, M,
+ $ WORK, LWORK, INFO)
+*
+* Compute |QT*C - QT*C| / |C|
+*
+ CALL CGEMM( 'C', 'N', M, N, M, -ONE, Q, M, C, M, ONE, CF, M )
+ RESID = CLANGE( '1', M, N, CF, M, RWORK )
+ IF( CNORM.GT.ZERO ) THEN
+ RESULT( 4 ) = RESID / (EPS*MAX(1,M)*CNORM)
+ ELSE
+ RESULT( 4 ) = ZERO
+ END IF
+*
+* Generate random n-by-m matrix D and a copy DF
+*
+ DO J=1,M
+ CALL CLARNV( 2, ISEED, N, D( 1, J ) )
+ END DO
+ DNORM = CLANGE( '1', N, M, D, N, RWORK)
+ CALL CLACPY( 'Full', N, M, D, N, DF, N )
+*
+* 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)
+*
+* Compute |D*Q - D*Q| / |D|
+*
+ CALL CGEMM( 'N', 'N', N, M, M, -ONE, D, N, Q, M, ONE, DF, N )
+ RESID = CLANGE( '1', N, M, DF, N, RWORK )
+ IF( DNORM.GT.ZERO ) THEN
+ RESULT( 5 ) = RESID / (EPS*MAX(1,M)*DNORM)
+ ELSE
+ RESULT( 5 ) = ZERO
+ END IF
+*
+* Copy D into DF again
+*
+ CALL CLACPY( 'Full', N, M, D, N, DF, N )
+*
+* Apply Q to D as D*QT
+*
+ CALL CGEMQR( 'R', 'C', N, M, K, AF, M, T, LT, DF, N,
+ $ WORK, LWORK, INFO)
+*
+* Compute |D*QT - D*QT| / |D|
+*
+ CALL CGEMM( 'N', 'C', N, M, M, -ONE, D, N, Q, M, ONE, DF, N )
+ RESID = CLANGE( '1', N, M, DF, N, RWORK )
+ IF( CNORM.GT.ZERO ) THEN
+ RESULT( 6 ) = RESID / (EPS*MAX(1,M)*DNORM)
+ ELSE
+ RESULT( 6 ) = ZERO
+ END IF
+*
+* Short and wide
+*
+ ELSE
+ srnamt = 'CGELQ'
+ CALL CGELQ( M, N, AF, M, T, LT, WORK, LWORK, INFO )
+*
+*
+* Generate the n-by-n matrix Q
+*
+ CALL CLASET( 'Full', N, N, CZERO, ONE, Q, N )
+ srnamt = 'CGEMLQ'
+ CALL CGEMLQ( 'R', 'N', N, N, K, AF, M, T, LT, Q, N,
+ $ WORK, LWORK, INFO )
+*
+* Copy R
+*
+ CALL CLASET( 'Full', M, N, CZERO, CZERO, LQ, L )
+ CALL CLACPY( 'Lower', M, N, AF, M, LQ, L )
+*
+* Compute |L - A*Q'| / |A| and store in RESULT(1)
+*
+ CALL CGEMM( 'N', 'C', M, N, N, -ONE, A, M, Q, N, ONE, LQ, L )
+ ANORM = CLANGE( '1', M, N, A, M, RWORK )
+ RESID = CLANGE( '1', M, N, LQ, L, RWORK )
+ IF( ANORM.GT.ZERO ) THEN
+ RESULT( 1 ) = RESID / (EPS*MAX(1,N)*ANORM)
+ ELSE
+ RESULT( 1 ) = ZERO
+ END IF
+*
+* Compute |I - Q'*Q| and store in RESULT(2)
+*
+ CALL CLASET( 'Full', N, N, CZERO, ONE, LQ, L )
+ CALL CHERK( 'U', 'C', N, N, REAL(-ONE), Q, N, REAL(ONE), LQ, L)
+ RESID = CLANSY( '1', 'Upper', N, LQ, L, RWORK )
+ RESULT( 2 ) = RESID / (EPS*MAX(1,N))
+*
+* Generate random m-by-n matrix C and a copy CF
+*
+ DO J=1,M
+ CALL CLARNV( 2, ISEED, N, D( 1, J ) )
+ END DO
+ DNORM = CLANGE( '1', N, M, D, N, RWORK)
+ CALL CLACPY( 'Full', N, M, D, N, DF, N )
+*
+* Apply Q to C as Q*C
+*
+ CALL CGEMLQ( 'L', 'N', N, M, K, AF, M, T, LT, DF, N,
+ $ WORK, LWORK, INFO)
+*
+* Compute |Q*D - Q*D| / |D|
+*
+ CALL CGEMM( 'N', 'N', N, M, N, -ONE, Q, N, D, N, ONE, DF, N )
+ RESID = CLANGE( '1', N, M, DF, N, RWORK )
+ IF( DNORM.GT.ZERO ) THEN
+ RESULT( 3 ) = RESID / (EPS*MAX(1,N)*DNORM)
+ ELSE
+ RESULT( 3 ) = ZERO
+ END IF
+*
+* Copy D into DF again
+*
+ CALL CLACPY( 'Full', N, M, D, N, DF, N )
+*
+* Apply Q to D as QT*D
+*
+ CALL CGEMLQ( 'L', 'C', N, M, K, AF, M, T, LT, DF, N,
+ $ WORK, LWORK, INFO)
+*
+* Compute |QT*D - QT*D| / |D|
+*
+ CALL CGEMM( 'C', 'N', N, M, N, -ONE, Q, N, D, N, ONE, DF, N )
+ RESID = CLANGE( '1', N, M, DF, N, RWORK )
+ IF( DNORM.GT.ZERO ) THEN
+ RESULT( 4 ) = RESID / (EPS*MAX(1,N)*DNORM)
+ ELSE
+ RESULT( 4 ) = ZERO
+ END IF
+*
+* Generate random n-by-m matrix D and a copy DF
+*
+ DO J=1,N
+ CALL CLARNV( 2, ISEED, M, C( 1, J ) )
+ END DO
+ CNORM = CLANGE( '1', M, N, C, M, RWORK)
+ CALL CLACPY( 'Full', M, N, C, M, CF, M )
+*
+* Apply Q to C as C*Q
+*
+ CALL CGEMLQ( 'R', 'N', M, N, K, AF, M, T, LT, CF, M,
+ $ WORK, LWORK, INFO)
+*
+* Compute |C*Q - C*Q| / |C|
+*
+ CALL CGEMM( 'N', 'N', M, N, N, -ONE, C, M, Q, N, ONE, CF, M )
+ RESID = CLANGE( '1', N, M, DF, N, RWORK )
+ IF( CNORM.GT.ZERO ) THEN
+ RESULT( 5 ) = RESID / (EPS*MAX(1,N)*CNORM)
+ ELSE
+ RESULT( 5 ) = ZERO
+ END IF
+*
+* Copy C into CF again
+*
+ CALL CLACPY( 'Full', M, N, C, M, CF, M )
+*
+* Apply Q to D as D*QT
+*
+ CALL CGEMLQ( 'R', 'C', M, N, K, AF, M, T, LT, CF, M,
+ $ WORK, LWORK, INFO)
+*
+* Compute |C*QT - C*QT| / |C|
+*
+ CALL CGEMM( 'N', 'C', M, N, N, -ONE, C, M, Q, N, ONE, CF, M )
+ RESID = CLANGE( '1', M, N, CF, M, RWORK )
+ IF( CNORM.GT.ZERO ) THEN
+ RESULT( 6 ) = RESID / (EPS*MAX(1,N)*CNORM)
+ ELSE
+ RESULT( 6 ) = ZERO
+ END IF
+*
+ END IF
+*
+* Deallocate all arrays
+*
+ DEALLOCATE ( A, AF, Q, R, RWORK, WORK, T, C, D, CF, DF)
+*
+ RETURN
+ END
\ No newline at end of file
*
* =========== 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:
* ===========
*
* PROGRAM DCHKAA
-*
+*
*
*> \par Purpose:
* =============
*> DPP 9 List types on next line if 0 < NTYPES < 9
*> DPB 8 List types on next line if 0 < NTYPES < 8
*> DPT 12 List types on next line if 0 < NTYPES < 12
-*> DSA 10 List types on next line if 0 < NTYPES < 10
*> DSY 10 List types on next line if 0 < NTYPES < 10
*> DSR 10 List types on next line if 0 < NTYPES < 10
*> DSP 10 List types on next line if 0 < NTYPES < 10
* 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
*
$ DCHKSY_ROOK, DCHKTB, DCHKTP, DCHKTR, DCHKTZ,
$ DDRVGB, DDRVGE, DDRVGT, DDRVLS, DDRVPB, DDRVPO,
$ DDRVPP, DDRVPT, DDRVSP, DDRVSY, DDRVSY_ROOK,
- $ ILAVER, DCHKQRT, DCHKQRTP
+ $ ILAVER, DCHKQRT, DCHKQRTP, DCHKLQTP, DCHKTSQR,
+ $ DCHKLQT
+
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
WRITE( NOUT, FMT = 9988 )PATH
END IF
*
- ELSE IF( LSAMEN( 2, C2, 'SA' ) ) THEN
-*
-* SY: symmetric indefinite matrices,
-* with partial (Aasen's) pivoting algorithm
-*
- NTYPES = 10
- CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
-*
- IF( TSTCHK ) THEN
- CALL DCHKSY_AASEN( DOTYPE, NN, NVAL, NNB2, NBVAL2, NNS,
- $ 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 )
- ELSE
- WRITE( NOUT, FMT = 9989 )PATH
- END IF
-*
- IF( TSTDRV ) THEN
- CALL DDRVSY_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
- END IF
-*
-*
ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN
*
* SP: symmetric indefinite packed matrices,
ELSE
WRITE( NOUT, FMT = 9989 )PATH
END IF
-*
+*
ELSE IF( LSAMEN( 2, C2, 'QT' ) ) THEN
*
* QT: QRT routines for general matrices
*
IF( TSTCHK ) THEN
- CALL DCHKQRT( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
+ CALL DCHKQRT( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
$ NBVAL, NOUT )
ELSE
WRITE( NOUT, FMT = 9989 )PATH
* 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
+ END IF
+*
+ ELSE IF( LSAMEN( 2, C2, 'TQ' ) ) THEN
+*
+* TQ: LQT routines for general matrices
+*
+ IF( TSTCHK ) THEN
+ CALL DCHKLQT( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
+ $ NBVAL, NOUT )
+ ELSE
+ WRITE( NOUT, FMT = 9989 )PATH
+ END IF
+*
+ ELSE IF( LSAMEN( 2, C2, 'XQ' ) ) THEN
+*
+* XQ: LQT routines for triangular-pentagonal matrices
+*
+ IF( TSTCHK ) THEN
+ CALL DCHKLQTP( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
+ $ NBVAL, NOUT )
+ ELSE
+ WRITE( NOUT, FMT = 9989 )PATH
+ END IF
+*
+ ELSE IF( LSAMEN( 2, C2, 'TS' ) ) THEN
+*
+* TS: QR routines for tall-skinny matrices
+*
+ IF( TSTCHK ) THEN
+ CALL DCHKTSQR( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
$ NBVAL, NOUT )
ELSE
WRITE( NOUT, FMT = 9989 )PATH
--- /dev/null
+*> \brief \b DCHKLQT
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE DCHKLQT( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
+* NBVAL, NOUT )
+*
+* .. Scalar Arguments ..
+* LOGICAL TSTERR
+* INTEGER NM, NN, NNB, NOUT
+* DOUBLE PRECISION THRESH
+* ..
+* .. Array Arguments ..
+* INTEGER MVAL( * ), NBVAL( * ), NVAL( * )
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> DCHKLQT tests DGELQT and DGEMLQT.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] THRESH
+*> \verbatim
+*> THRESH is DOUBLE PRECISION
+*> The threshold value for the test ratios. A result is
+*> included in the output file if RESULT >= THRESH. To have
+*> every test ratio printed, use THRESH = 0.
+*> \endverbatim
+*>
+*> \param[in] TSTERR
+*> \verbatim
+*> TSTERR is LOGICAL
+*> Flag that indicates whether error exits are to be tested.
+*> \endverbatim
+*>
+*> \param[in] NM
+*> \verbatim
+*> NM is INTEGER
+*> The number of values of M contained in the vector MVAL.
+*> \endverbatim
+*>
+*> \param[in] MVAL
+*> \verbatim
+*> MVAL is INTEGER array, dimension (NM)
+*> The values of the matrix row dimension M.
+*> \endverbatim
+*>
+*> \param[in] NN
+*> \verbatim
+*> NN is INTEGER
+*> The number of values of N contained in the vector NVAL.
+*> \endverbatim
+*>
+*> \param[in] NVAL
+*> \verbatim
+*> NVAL is INTEGER array, dimension (NN)
+*> The values of the matrix column dimension N.
+*> \endverbatim
+*>
+*> \param[in] NNB
+*> \verbatim
+*> NNB is INTEGER
+*> The number of values of NB contained in the vector NBVAL.
+*> \endverbatim
+*>
+*> \param[in] NBVAL
+*> \verbatim
+*> NBVAL is INTEGER array, dimension (NBVAL)
+*> The values of the blocksize NB.
+*> \endverbatim
+*>
+*> \param[in] NOUT
+*> \verbatim
+*> NOUT is INTEGER
+*> The unit number for output.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \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,
+ $ NBVAL, NOUT )
+ IMPLICIT NONE
+*
+* -- LAPACK test routine (version 3.4.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2011
+*
+* .. Scalar Arguments ..
+ LOGICAL TSTERR
+ INTEGER NM, NN, NNB, NOUT
+ DOUBLE PRECISION THRESH
+* ..
+* .. Array Arguments ..
+ INTEGER MVAL( * ), NBVAL( * ), NVAL( * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER NTESTS
+ PARAMETER ( NTESTS = 6 )
+* ..
+* .. Local Scalars ..
+ CHARACTER*3 PATH
+ INTEGER I, J, K, T, M, N, NB, NFAIL, NERRS, NRUN,
+ $ MINMN
+*
+* .. Local Arrays ..
+ DOUBLE PRECISION RESULT( NTESTS )
+* ..
+* .. External Subroutines ..
+ EXTERNAL ALAERH, ALAHD, ALASUM, DERRLQT, DLQT04
+* ..
+* .. Scalars in Common ..
+ LOGICAL LERR, OK
+ CHARACTER*32 SRNAMT
+ INTEGER INFOT, NUNIT
+* ..
+* .. Common blocks ..
+ COMMON / INFOC / INFOT, NUNIT, OK, LERR
+ COMMON / SRNAMC / SRNAMT
+* ..
+* .. Executable Statements ..
+*
+* Initialize constants
+*
+ PATH( 1: 1 ) = 'D'
+ PATH( 2: 3 ) = 'TQ'
+ NRUN = 0
+ NFAIL = 0
+ NERRS = 0
+*
+* Test the error exits
+*
+ IF( TSTERR ) CALL DERRLQT( PATH, NOUT )
+ INFOT = 0
+*
+* Do for each value of M in MVAL.
+*
+ DO I = 1, NM
+ M = MVAL( I )
+*
+* Do for each value of N in NVAL.
+*
+ DO J = 1, NN
+ N = NVAL( J )
+*
+* Do for each possible value of NB
+*
+ MINMN = MIN( M, N )
+ DO K = 1, NNB
+ NB = NBVAL( K )
+*
+* Test DGELQT and DGEMLQT
+*
+ IF( (NB.LE.MINMN).AND.(NB.GT.0) ) THEN
+ CALL DLQT04( M, N, NB, RESULT )
+*
+* Print information about the tests that did not
+* pass the threshold.
+*
+ DO T = 1, NTESTS
+ IF( RESULT( T ).GE.THRESH ) THEN
+ IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
+ $ CALL ALAHD( NOUT, PATH )
+ WRITE( NOUT, FMT = 9999 )M, N, NB,
+ $ T, RESULT( T )
+ NFAIL = NFAIL + 1
+ END IF
+ END DO
+ NRUN = NRUN + NTESTS
+ END IF
+ END DO
+ END DO
+ END DO
+*
+* Print a summary of the results.
+*
+ CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
+*
+ 9999 FORMAT( ' M=', I5, ', N=', I5, ', NB=', I4,
+ $ ' test(', I2, ')=', G12.5 )
+ RETURN
+*
+* End of DCHKLQT
+*
+ END
--- /dev/null
+*> \brief \b DCHKLQTP
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE DCHKLQTP( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
+* NBVAL, NOUT )
+*
+* .. Scalar Arguments ..
+* LOGICAL TSTERR
+* INTEGER NM, NN, NNB, NOUT
+* DOUBLE PRECISION THRESH
+* ..
+* .. Array Arguments ..
+* INTEGER MVAL( * ), NBVAL( * ), NVAL( * )
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> DCHKLQTP tests DTPLQT and DTPMLQT.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] THRESH
+*> \verbatim
+*> THRESH is DOUBLE PRECISION
+*> The threshold value for the test ratios. A result is
+*> included in the output file if RESULT >= THRESH. To have
+*> every test ratio printed, use THRESH = 0.
+*> \endverbatim
+*>
+*> \param[in] TSTERR
+*> \verbatim
+*> TSTERR is LOGICAL
+*> Flag that indicates whether error exits are to be tested.
+*> \endverbatim
+*>
+*> \param[in] NM
+*> \verbatim
+*> NM is INTEGER
+*> The number of values of M contained in the vector MVAL.
+*> \endverbatim
+*>
+*> \param[in] MVAL
+*> \verbatim
+*> MVAL is INTEGER array, dimension (NM)
+*> The values of the matrix row dimension M.
+*> \endverbatim
+*>
+*> \param[in] NN
+*> \verbatim
+*> NN is INTEGER
+*> The number of values of N contained in the vector NVAL.
+*> \endverbatim
+*>
+*> \param[in] NVAL
+*> \verbatim
+*> NVAL is INTEGER array, dimension (NN)
+*> The values of the matrix column dimension N.
+*> \endverbatim
+*>
+*> \param[in] NNB
+*> \verbatim
+*> NNB is INTEGER
+*> The number of values of NB contained in the vector NBVAL.
+*> \endverbatim
+*>
+*> \param[in] NBVAL
+*> \verbatim
+*> NBVAL is INTEGER array, dimension (NBVAL)
+*> The values of the blocksize NB.
+*> \endverbatim
+*>
+*> \param[in] NOUT
+*> \verbatim
+*> NOUT is INTEGER
+*> The unit number for output.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \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,
+ $ NBVAL, NOUT )
+ IMPLICIT NONE
+*
+* -- LAPACK test routine (version 3.4.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2011
+*
+* .. Scalar Arguments ..
+ LOGICAL TSTERR
+ INTEGER NM, NN, NNB, NOUT
+ DOUBLE PRECISION THRESH
+* ..
+* .. Array Arguments ..
+ INTEGER MVAL( * ), NBVAL( * ), NVAL( * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER NTESTS
+ PARAMETER ( NTESTS = 6 )
+* ..
+* .. Local Scalars ..
+ CHARACTER*3 PATH
+ INTEGER I, J, K, L, T, M, N, NB, NFAIL, NERRS, NRUN,
+ $ MINMN
+* ..
+* .. Local Arrays ..
+ DOUBLE PRECISION RESULT( NTESTS )
+* ..
+* .. External Subroutines ..
+ EXTERNAL ALAERH, ALAHD, ALASUM, DERRLQTP, DLQT04
+* ..
+* .. Scalars in Common ..
+ LOGICAL LERR, OK
+ CHARACTER*32 SRNAMT
+ INTEGER INFOT, NUNIT
+* ..
+* .. Common blocks ..
+ COMMON / INFOC / INFOT, NUNIT, OK, LERR
+ COMMON / SRNAMC / SRNAMT
+* ..
+* .. Executable Statements ..
+*
+* Initialize constants
+*
+ PATH( 1: 1 ) = 'D'
+ PATH( 2: 3 ) = 'XQ'
+ NRUN = 0
+ NFAIL = 0
+ NERRS = 0
+*
+* Test the error exits
+*
+ IF( TSTERR ) CALL DERRLQTP( PATH, NOUT )
+ INFOT = 0
+*
+* Do for each value of M
+*
+ DO I = 1, NM
+ M = MVAL( I )
+*
+* Do for each value of N
+*
+ DO J = 1, NN
+ N = NVAL( J )
+*
+* Do for each value of L
+*
+ 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 )
+*
+* Print information about the tests that did not
+* pass the threshold.
+*
+ DO T = 1, NTESTS
+ IF( RESULT( T ).GE.THRESH ) THEN
+ IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
+ $ CALL ALAHD( NOUT, PATH )
+ WRITE( NOUT, FMT = 9999 )M, N, NB, L,
+ $ T, RESULT( T )
+ NFAIL = NFAIL + 1
+ END IF
+ END DO
+ NRUN = NRUN + NTESTS
+ END IF
+ END DO
+ END DO
+ END DO
+ END DO
+*
+* Print a summary of the results.
+*
+ CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
+*
+ 9999 FORMAT( ' M=', I5, ', N=', I5, ', NB=', I4,' L=', I4,
+ $ ' test(', I2, ')=', G12.5 )
+ RETURN
+*
+* End of DCHKQRTP
+*
+ END
--- /dev/null
+*> \brief \b DCHKQRT
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE DCHKTSQR( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
+* NBVAL, NOUT )
+*
+* .. Scalar Arguments ..
+* LOGICAL TSTERR
+* INTEGER NM, NN, NNB, NOUT
+* DOUBLE PRECISION THRESH
+* ..
+* .. Array Arguments ..
+* INTEGER MVAL( * ), NBVAL( * ), NVAL( * )
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> DCHKTSQR tests DGETSQR and DORMTSQR.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] THRESH
+*> \verbatim
+*> THRESH is DOUBLE PRECISION
+*> The threshold value for the test ratios. A result is
+*> included in the output file if RESULT >= THRESH. To have
+*> every test ratio printed, use THRESH = 0.
+*> \endverbatim
+*>
+*> \param[in] TSTERR
+*> \verbatim
+*> TSTERR is LOGICAL
+*> Flag that indicates whether error exits are to be tested.
+*> \endverbatim
+*>
+*> \param[in] NM
+*> \verbatim
+*> NM is INTEGER
+*> The number of values of M contained in the vector MVAL.
+*> \endverbatim
+*>
+*> \param[in] MVAL
+*> \verbatim
+*> MVAL is INTEGER array, dimension (NM)
+*> The values of the matrix row dimension M.
+*> \endverbatim
+*>
+*> \param[in] NN
+*> \verbatim
+*> NN is INTEGER
+*> The number of values of N contained in the vector NVAL.
+*> \endverbatim
+*>
+*> \param[in] NVAL
+*> \verbatim
+*> NVAL is INTEGER array, dimension (NN)
+*> The values of the matrix column dimension N.
+*> \endverbatim
+*>
+*> \param[in] NNB
+*> \verbatim
+*> NNB is INTEGER
+*> The number of values of NB contained in the vector NBVAL.
+*> \endverbatim
+*>
+*> \param[in] NBVAL
+*> \verbatim
+*> NBVAL is INTEGER array, dimension (NBVAL)
+*> The values of the blocksize NB.
+*> \endverbatim
+*>
+*> \param[in] NOUT
+*> \verbatim
+*> NOUT is INTEGER
+*> The unit number for output.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \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,
+ $ NBVAL, NOUT )
+ IMPLICIT NONE
+*
+* -- LAPACK test routine (version 3.4.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2011
+*
+* .. Scalar Arguments ..
+ LOGICAL TSTERR
+ INTEGER NM, NN, NNB, NOUT
+ DOUBLE PRECISION THRESH
+* ..
+* .. Array Arguments ..
+ INTEGER MVAL( * ), NBVAL( * ), NVAL( * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER NTESTS
+ PARAMETER ( NTESTS = 6 )
+* ..
+* .. Local Scalars ..
+ CHARACTER*3 PATH
+ INTEGER I, J, K, T, M, N, NB, NFAIL, NERRS, NRUN, INB,
+ $ MINMN, MB, IMB
+*
+* .. Local Arrays ..
+ DOUBLE PRECISION RESULT( NTESTS )
+* ..
+* .. External Subroutines ..
+ EXTERNAL ALAERH, ALAHD, ALASUM, DERRTSQR,
+ $ DTSQR01, XLAENV
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Scalars in Common ..
+ LOGICAL LERR, OK
+ CHARACTER*32 SRNAMT
+ INTEGER INFOT, NUNIT
+* ..
+* .. Common blocks ..
+ COMMON / INFOC / INFOT, NUNIT, OK, LERR
+ COMMON / SRNAMC / SRNAMT
+* ..
+* .. Executable Statements ..
+*
+* Initialize constants
+*
+ PATH( 1: 1 ) = 'D'
+ PATH( 2: 3 ) = 'TS'
+ NRUN = 0
+ NFAIL = 0
+ NERRS = 0
+*
+* Test the error exits
+*
+ IF( TSTERR ) CALL DERRTSQR( PATH, NOUT )
+ INFOT = 0
+*
+* Do for each value of M in MVAL.
+*
+ DO I = 1, NM
+ M = MVAL( I )
+*
+* Do for each value of N in NVAL.
+*
+ DO J = 1, NN
+ N = NVAL( J )
+ IF (MIN(M,N).NE.0) THEN
+ DO INB = 1, NNB
+ MB = NBVAL( INB )
+ CALL XLAENV( 1, MB )
+ DO IMB = 1, NNB
+ NB = NBVAL( IMB )
+ CALL XLAENV( 2, NB )
+*
+* Test DGEQR and DGEMQR
+*
+ CALL DTSQR01( 'TS', M, N, MB, NB, RESULT )
+*
+* Print information about the tests that did not
+* pass the threshold.
+*
+ DO T = 1, NTESTS
+ IF( RESULT( T ).GE.THRESH ) THEN
+ IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
+ $ CALL ALAHD( NOUT, PATH )
+ WRITE( NOUT, FMT = 9999 )M, N, MB, NB,
+ $ T, RESULT( T )
+ NFAIL = NFAIL + 1
+ END IF
+ END DO
+ NRUN = NRUN + NTESTS
+ END DO
+ END DO
+ END IF
+ END DO
+ END DO
+*
+* Do for each value of M in MVAL.
+*
+ DO I = 1, NM
+ M = MVAL( I )
+*
+* Do for each value of N in NVAL.
+*
+ DO J = 1, NN
+ N = NVAL( J )
+ IF (MIN(M,N).NE.0) THEN
+ DO INB = 1, NNB
+ MB = NBVAL( INB )
+ CALL XLAENV( 1, MB )
+ DO IMB = 1, NNB
+ NB = NBVAL( IMB )
+ CALL XLAENV( 2, NB )
+*
+* Test DGEQR and DGEMQR
+*
+ CALL DTSQR01( 'SW', M, N, MB, NB, RESULT )
+*
+* Print information about the tests that did not
+* pass the threshold.
+*
+ DO T = 1, NTESTS
+ IF( RESULT( T ).GE.THRESH ) THEN
+ IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
+ $ CALL ALAHD( NOUT, PATH )
+ WRITE( NOUT, FMT = 9998 )M, N, MB, NB,
+ $ T, RESULT( T )
+ NFAIL = NFAIL + 1
+ END IF
+ END DO
+ NRUN = NRUN + NTESTS
+ END DO
+ END DO
+ END IF
+ END DO
+ END DO
+*
+* Print a summary of the results.
+*
+ CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
+*
+ 9999 FORMAT( 'TS: M=', I5, ', N=', I5, ', MB=', I5,
+ $ ', NB=', I5,' test(', I2, ')=', G12.5 )
+ 9998 FORMAT( 'SW: M=', I5, ', N=', I5, ', MB=', I5,
+ $ ', NB=', I5,' test(', I2, ')=', G12.5 )
+ RETURN
+*
+* End of DCHKQRT
+*
+ END
\ No newline at end of file
*
* =========== 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 DDRVLS( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, NNB,
* NBVAL, NXVAL, THRESH, TSTERR, A, COPYA, B,
* COPYB, C, S, COPYS, WORK, IWORK, NOUT )
-*
+*
* .. Scalar Arguments ..
* LOGICAL TSTERR
* INTEGER NM, NN, NNB, NNS, NOUT
* DOUBLE PRECISION A( * ), B( * ), C( * ), COPYA( * ), COPYB( * ),
* $ COPYS( * ), S( * ), WORK( * )
* ..
-*
+*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
-*> DDRVLS tests the least squares driver routines DGELS, DGELSS, DGELSY,
+*> DDRVLS tests the least squares driver routines DGELS, DGETSLS, DGELSS, DGELSY,
*> and DGELSD.
*> \endverbatim
*
*> .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
*> The matrix of type j is generated as follows:
*> j=1: A = U*D*V where U and V are random orthogonal matrices
-*> and D has random entries (> 0.1) taken from a uniform
+*> and D has random entries (> 0.1) taken from a uniform
*> distribution (0,1). A is full rank.
*> j=2: The same of 1, but A is scaled up.
*> j=3: The same of 1, but A is scaled down.
*> j=4: A = U*D*V where U and V are random orthogonal matrices
*> and D has 3*min(M,N)/4 random entries (> 0.1) taken
*> from a uniform distribution (0,1) and the remaining
-*> entries set to 0. A is rank-deficient.
+*> entries set to 0. A is rank-deficient.
*> j=5: The same of 4, but A is scaled up.
*> j=6: The same of 5, but A is scaled down.
*> \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
*
*
* .. Parameters ..
INTEGER NTESTS
- PARAMETER ( NTESTS = 14 )
+ PARAMETER ( NTESTS = 16 )
INTEGER SMLSIZ
PARAMETER ( SMLSIZ = 25 )
DOUBLE PRECISION ONE, TWO, ZERO
* .. Local Scalars ..
CHARACTER TRANS
CHARACTER*3 PATH
- INTEGER CRANK, I, IM, 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
+ INTEGER CRANK, I, IM, 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
* ..
* .. Local Arrays ..
*
DO 140 IN = 1, NN
N = NVAL( IN )
- MNMIN = MIN( M, N )
+ MNMIN = MAX(MIN( M, N ),1)
LDB = MAX( 1, M, N )
+ MB = (MNMIN+1)
+ IF(MINMN.NE.MB) THEN
+ LWTS = (((LDB-MB)/(MB-MNMIN))*MNMIN+MNMIN*2)*MB+5
+ ELSE
+ LWTS = 2*MINMN+5
+ END IF
*
DO 130 INS = 1, NNS
NRHS = NSVAL( INS )
$ DBLE( SMLSIZ+1 ) ) / LOG( TWO ) ) + 1, 0 )
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 )
+ $ 8*MNMIN*NLVL+MNMIN*NRHS+(SMLSIZ+1)**2,LWTS)
+ $
*
DO 120 IRANK = 1, 2
DO 110 ISCALE = 1, 3
NRUN = NRUN + 2
30 CONTINUE
40 CONTINUE
+*
+*
+* Test DGETSLS
+*
+* Generate a matrix of scaling type ISCALE
+*
+ CALL DQRT13( ISCALE, M, N, COPYA, LDA, NORMA,
+ $ ISEED )
+ DO 65 INB = 1, NNB
+ MB = NBVAL( INB )
+ CALL XLAENV( 1, MB )
+ DO 62 IMB = 1, NNB
+ NB = NBVAL( IMB )
+ CALL XLAENV( 2, NB )
+*
+ DO 60 ITRAN = 1, 2
+ IF( ITRAN.EQ.1 ) THEN
+ TRANS = 'N'
+ NROWS = M
+ NCOLS = N
+ ELSE
+ TRANS = 'T'
+ NROWS = N
+ NCOLS = M
+ END IF
+ LDWORK = MAX( 1, NCOLS )
+*
+* Set up a consistent rhs
+*
+ IF( NCOLS.GT.0 ) THEN
+ CALL DLARNV( 2, ISEED, NCOLS*NRHS,
+ $ WORK )
+ CALL DSCAL( NCOLS*NRHS,
+ $ ONE / DBLE( NCOLS ), WORK,
+ $ 1 )
+ END IF
+ CALL DGEMM( TRANS, 'No transpose', NROWS,
+ $ NRHS, NCOLS, ONE, COPYA, LDA,
+ $ WORK, LDWORK, ZERO, B, LDB )
+ CALL DLACPY( 'Full', NROWS, NRHS, B, LDB,
+ $ COPYB, LDB )
+*
+* Solve LS or overdetermined system
+*
+ IF( M.GT.0 .AND. N.GT.0 ) THEN
+ CALL DLACPY( 'Full', M, N, COPYA, LDA,
+ $ A, LDA )
+ CALL DLACPY( 'Full', NROWS, NRHS,
+ $ COPYB, LDB, B, LDB )
+ END IF
+ SRNAMT = 'DGETSLS '
+ CALL DGETSLS( TRANS, M, N, NRHS, A,
+ $ LDA, B, LDB, WORK, LWORK, INFO )
+ IF( INFO.NE.0 )
+ $ CALL ALAERH( PATH, 'DGETSLS ', INFO, 0,
+ $ TRANS, M, N, NRHS, -1, NB,
+ $ ITYPE, NFAIL, NERRS,
+ $ NOUT )
+*
+* Check correctness of results
+*
+ LDWORK = MAX( 1, NROWS )
+ IF( NROWS.GT.0 .AND. NRHS.GT.0 )
+ $ CALL DLACPY( 'Full', NROWS, NRHS,
+ $ COPYB, LDB, C, LDB )
+ CALL DQRT16( TRANS, M, N, NRHS, COPYA,
+ $ LDA, B, LDB, C, LDB, WORK,
+ $ RESULT( 15 ) )
+*
+ IF( ( ITRAN.EQ.1 .AND. M.GE.N ) .OR.
+ $ ( ITRAN.EQ.2 .AND. M.LT.N ) ) THEN
+*
+* Solving LS system
+*
+ RESULT( 16 ) = DQRT17( TRANS, 1, M, N,
+ $ NRHS, COPYA, LDA, B, LDB,
+ $ COPYB, LDB, C, WORK,
+ $ LWORK )
+ ELSE
+*
+* Solving overdetermined system
+*
+ RESULT( 16 ) = DQRT14( TRANS, M, N,
+ $ NRHS, COPYA, LDA, B, LDB,
+ $ WORK, LWORK )
+ END IF
+*
+* Print information about the tests that
+* did not pass the threshold.
+*
+ DO 50 K = 15, 16
+ IF( RESULT( K ).GE.THRESH ) THEN
+ IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
+ $ CALL ALAHD( NOUT, PATH )
+ WRITE( NOUT, FMT = 9997 )TRANS, M,
+ $ N, NRHS, MB, NB, ITYPE, K,
+ $ RESULT( K )
+ NFAIL = NFAIL + 1
+ END IF
+ 50 CONTINUE
+ NRUN = NRUN + 2
+ 60 CONTINUE
+ 62 CONTINUE
+ 65 CONTINUE
END IF
*
* Generate a matrix of scaling type ISCALE and rank
* Print information about the tests that did not
* pass the threshold.
*
- DO 90 K = 3, NTESTS
+ DO 90 K = 3, 14
IF( RESULT( K ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
NFAIL = NFAIL + 1
END IF
90 CONTINUE
- NRUN = NRUN + 12
+ NRUN = NRUN + 12
*
100 CONTINUE
110 CONTINUE
$ ', 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,
+ $ ', test(', I2, ')=', G12.5 )
RETURN
*
* End of DDRVLS
--- /dev/null
+*> \brief \b DERLQT
+*
+* =========== DOCUMENTATION ===========
+*
+* 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:
+* =============
+*>
+*> \verbatim
+*>
+*> DERRLQT tests the error exits for the DOUBLE PRECISION routines
+*> that use the LQT decomposition of a general matrix.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] PATH
+*> \verbatim
+*> PATH is CHARACTER*3
+*> The LAPACK path name for the routines to be tested.
+*> \endverbatim
+*>
+*> \param[in] NUNIT
+*> \verbatim
+*> NUNIT is INTEGER
+*> The unit number for output.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2011
+*
+*> \ingroup double_lin
+*
+* =====================================================================
+ SUBROUTINE DERRLQT( PATH, NUNIT )
+ IMPLICIT NONE
+*
+* -- LAPACK test routine (version 3.4.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2011
+*
+* .. Scalar Arguments ..
+ CHARACTER*3 PATH
+ INTEGER NUNIT
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER NMAX
+ PARAMETER ( NMAX = 2 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, INFO, J
+* ..
+* .. Local Arrays ..
+ DOUBLE PRECISION A( NMAX, NMAX ), T( NMAX, NMAX ), W( NMAX ),
+ $ C( NMAX, NMAX )
+* ..
+* .. External Subroutines ..
+ EXTERNAL ALAESM, CHKXER, DGELQT3, DGELQT,
+ $ DGEMLQT
+* ..
+* .. Scalars in Common ..
+ LOGICAL LERR, OK
+ CHARACTER*32 SRNAMT
+ INTEGER INFOT, NOUT
+* ..
+* .. Common blocks ..
+ COMMON / INFOC / INFOT, NOUT, OK, LERR
+ COMMON / SRNAMC / SRNAMT
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC DBLE
+* ..
+* .. Executable Statements ..
+*
+ NOUT = NUNIT
+ WRITE( NOUT, FMT = * )
+*
+* Set the variables to innocuous values.
+*
+ DO J = 1, NMAX
+ DO I = 1, NMAX
+ A( I, J ) = 1.D0 / DBLE( I+J )
+ C( I, J ) = 1.D0 / DBLE( I+J )
+ T( I, J ) = 1.D0 / DBLE( I+J )
+ END DO
+ W( J ) = 0.D0
+ END DO
+ OK = .TRUE.
+*
+* Error exits for LQT factorization
+*
+* DGELQT
+*
+ SRNAMT = 'DGELQT'
+ INFOT = 1
+ CALL DGELQT( -1, 0, 1, A, 1, T, 1, W, INFO )
+ CALL CHKXER( 'DGELQT', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DGELQT( 0, -1, 1, A, 1, T, 1, W, INFO )
+ CALL CHKXER( 'DGELQT', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL DGELQT( 0, 0, 0, A, 1, T, 1, W, INFO )
+ CALL CHKXER( 'DGELQT', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL DGELQT( 2, 1, 1, A, 1, T, 1, W, INFO )
+ CALL CHKXER( 'DGELQT', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL DGELQT( 2, 2, 2, A, 2, T, 1, W, INFO )
+ CALL CHKXER( 'DGELQT', INFOT, NOUT, LERR, OK )
+*
+* DGELQT3
+*
+ SRNAMT = 'DGELQT3'
+ INFOT = 1
+ CALL DGELQT3( -1, 0, A, 1, T, 1, INFO )
+ CALL CHKXER( 'DGELQT3', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DGELQT3( 0, -1, A, 1, T, 1, INFO )
+ CALL CHKXER( 'DGELQT3', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL DGELQT3( 2, 2, A, 1, T, 1, INFO )
+ CALL CHKXER( 'DGELQT3', INFOT, NOUT, LERR, OK )
+ INFOT = 6
+ CALL DGELQT3( 2, 2, A, 2, T, 1, INFO )
+ CALL CHKXER( 'DGELQT3', INFOT, NOUT, LERR, OK )
+*
+* DGEMLQT
+*
+ SRNAMT = 'DGEMLQT'
+ INFOT = 1
+ CALL DGEMLQT( '/', 'N', 0, 0, 0, 1, A, 1, T, 1, C, 1, W, INFO )
+ CALL CHKXER( 'DGEMLQT', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DGEMLQT( 'L', '/', 0, 0, 0, 1, A, 1, T, 1, C, 1, W, INFO )
+ CALL CHKXER( 'DGEMLQT', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL DGEMLQT( 'L', 'N', -1, 0, 0, 1, A, 1, T, 1, C, 1, W, INFO )
+ CALL CHKXER( 'DGEMLQT', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL DGEMLQT( 'L', 'N', 0, -1, 0, 1, A, 1, T, 1, C, 1, W, INFO )
+ CALL CHKXER( 'DGEMLQT', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL DGEMLQT( 'L', 'N', 0, 0, -1, 1, A, 1, T, 1, C, 1, W, INFO )
+ CALL CHKXER( 'DGEMLQT', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL DGEMLQT( 'R', 'N', 0, 0, -1, 1, A, 1, T, 1, C, 1, W, INFO )
+ CALL CHKXER( 'DGEMLQT', INFOT, NOUT, LERR, OK )
+ INFOT = 6
+ CALL DGEMLQT( 'L', 'N', 0, 0, 0, 0, A, 1, T, 1, C, 1, W, INFO )
+ CALL CHKXER( 'DGEMLQT', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL DGEMLQT( 'R', 'N', 2, 2, 2, 1, A, 1, T, 1, C, 1, W, INFO )
+ CALL CHKXER( 'DGEMLQT', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL DGEMLQT( 'L', 'N', 2, 2, 2, 1, A, 1, T, 1, C, 1, W, INFO )
+ CALL CHKXER( 'DGEMLQT', INFOT, NOUT, LERR, OK )
+ INFOT = 10
+ CALL DGEMLQT( 'R', 'N', 1, 1, 1, 1, A, 1, T, 0, C, 1, W, INFO )
+ CALL CHKXER( 'DGEMLQT', INFOT, NOUT, LERR, OK )
+ INFOT = 12
+ CALL DGEMLQT( 'L', 'N', 1, 1, 1, 1, A, 1, T, 1, C, 0, W, INFO )
+ CALL CHKXER( 'DGEMLQT', INFOT, NOUT, LERR, OK )
+*
+* Print a summary line.
+*
+ CALL ALAESM( PATH, OK, NOUT )
+*
+ RETURN
+*
+* End of DERRLQT
+*
+ END
--- /dev/null
+*> \brief \b DERRLQTP
+*
+* =========== DOCUMENTATION ===========
+*
+* 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:
+* =============
+*>
+*> \verbatim
+*>
+*> DERRLQTP tests the error exits for the REAL routines
+*> that use the LQT decomposition of a triangular-pentagonal matrix.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] PATH
+*> \verbatim
+*> PATH is CHARACTER*3
+*> The LAPACK path name for the routines to be tested.
+*> \endverbatim
+*>
+*> \param[in] NUNIT
+*> \verbatim
+*> NUNIT is INTEGER
+*> The unit number for output.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2011
+*
+*> \ingroup double_lin
+*
+* =====================================================================
+ SUBROUTINE DERRLQTP( PATH, NUNIT )
+ IMPLICIT NONE
+*
+* -- LAPACK test routine (version 3.4.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2011
+*
+* .. Scalar Arguments ..
+ CHARACTER*3 PATH
+ INTEGER NUNIT
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER NMAX
+ PARAMETER ( NMAX = 2 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, INFO, J
+* ..
+* .. Local Arrays ..
+ DOUBLE PRECISION A( NMAX, NMAX ), T( NMAX, NMAX ), W( NMAX ),
+ $ B( NMAX, NMAX ), C( NMAX, NMAX )
+* ..
+* .. External Subroutines ..
+ EXTERNAL ALAESM, CHKXER, DTPLQT2, DTPLQT,
+ $ DTPMLQT
+* ..
+* .. Scalars in Common ..
+ LOGICAL LERR, OK
+ CHARACTER*32 SRNAMT
+ INTEGER INFOT, NOUT
+* ..
+* .. Common blocks ..
+ COMMON / INFOC / INFOT, NOUT, OK, LERR
+ COMMON / SRNAMC / SRNAMT
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC DBLE
+* ..
+* .. Executable Statements ..
+*
+ NOUT = NUNIT
+ WRITE( NOUT, FMT = * )
+*
+* Set the variables to innocuous values.
+*
+ DO J = 1, NMAX
+ DO I = 1, NMAX
+ A( I, J ) = 1.D0 / DBLE( I+J )
+ C( I, J ) = 1.D0 / DBLE( I+J )
+ T( I, J ) = 1.D0 / DBLE( I+J )
+ END DO
+ W( J ) = 0.0
+ END DO
+ OK = .TRUE.
+*
+* Error exits for TPLQT factorization
+*
+* DTPLQT
+*
+ SRNAMT = 'DTPLQT'
+ INFOT = 1
+ CALL DTPLQT( -1, 1, 0, 1, A, 1, B, 1, T, 1, W, INFO )
+ CALL CHKXER( 'DTPLQT', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DTPLQT( 1, -1, 0, 1, A, 1, B, 1, T, 1, W, INFO )
+ CALL CHKXER( 'DTPLQT', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL DTPLQT( 0, 1, -1, 1, A, 1, B, 1, T, 1, W, INFO )
+ CALL CHKXER( 'DTPLQT', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL DTPLQT( 0, 1, 1, 1, A, 1, B, 1, T, 1, W, INFO )
+ CALL CHKXER( 'DTPLQT', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL DTPLQT( 0, 1, 0, 0, A, 1, B, 1, T, 1, W, INFO )
+ CALL CHKXER( 'DTPLQT', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL DTPLQT( 1, 1, 0, 2, A, 1, B, 1, T, 1, W, INFO )
+ CALL CHKXER( 'DTPLQT', INFOT, NOUT, LERR, OK )
+ INFOT = 6
+ CALL DTPLQT( 2, 1, 0, 2, A, 1, B, 1, T, 1, W, INFO )
+ CALL CHKXER( 'DTPLQT', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL DTPLQT( 2, 1, 0, 1, A, 2, B, 1, T, 1, W, INFO )
+ CALL CHKXER( 'DTPLQT', INFOT, NOUT, LERR, OK )
+ INFOT = 10
+ CALL DTPLQT( 2, 2, 1, 2, A, 2, B, 2, T, 1, W, INFO )
+ CALL CHKXER( 'DTPLQT', INFOT, NOUT, LERR, OK )
+*
+* DTPLQT2
+*
+ SRNAMT = 'DTPLQT2'
+ INFOT = 1
+ CALL DTPLQT2( -1, 0, 0, A, 1, B, 1, T, 1, INFO )
+ CALL CHKXER( 'DTPLQT2', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DTPLQT2( 0, -1, 0, A, 1, B, 1, T, 1, INFO )
+ CALL CHKXER( 'DTPLQT2', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL DTPLQT2( 0, 0, -1, A, 1, B, 1, T, 1, INFO )
+ CALL CHKXER( 'DTPLQT2', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL DTPLQT2( 2, 2, 0, A, 1, B, 2, T, 2, INFO )
+ CALL CHKXER( 'DTPLQT2', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL DTPLQT2( 2, 2, 0, A, 2, B, 1, T, 2, INFO )
+ CALL CHKXER( 'DTPLQT2', INFOT, NOUT, LERR, OK )
+ INFOT = 9
+ CALL DTPLQT2( 2, 2, 0, A, 2, B, 2, T, 1, INFO )
+ CALL CHKXER( 'DTPLQT2', INFOT, NOUT, LERR, OK )
+*
+* DTPMLQT
+*
+ SRNAMT = 'DTPMLQT'
+ INFOT = 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,
+ $ 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,
+ $ 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,
+ $ 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,
+ $ W, INFO )
+ INFOT = 6
+ 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,
+ $ 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,
+ $ 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,
+ $ 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,
+ $ 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,
+ $ W, INFO )
+ CALL CHKXER( 'DTPMLQT', INFOT, NOUT, LERR, OK )
+*
+* Print a summary line.
+*
+ CALL ALAESM( PATH, OK, NOUT )
+*
+ RETURN
+*
+* End of DERRLQT
+*
+ END
--- /dev/null
+*> \brief \b DERRTSQR
+*
+* =========== DOCUMENTATION ===========
+*
+* 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:
+* =============
+*>
+*> \verbatim
+*>
+*> DERRTSQR tests the error exits for the DOUBLE PRECISION routines
+*> that use the TSQR decomposition of a general matrix.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] PATH
+*> \verbatim
+*> PATH is CHARACTER*3
+*> The LAPACK path name for the routines to be tested.
+*> \endverbatim
+*>
+*> \param[in] NUNIT
+*> \verbatim
+*> NUNIT is INTEGER
+*> The unit number for output.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2011
+*
+*> \ingroup double_lin
+*
+* =====================================================================
+ SUBROUTINE DERRTSQR( PATH, NUNIT )
+ IMPLICIT NONE
+*
+* -- LAPACK test routine (version 3.4.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2011
+*
+* .. Scalar Arguments ..
+ CHARACTER*3 PATH
+ INTEGER NUNIT
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER NMAX
+ PARAMETER ( NMAX = 2 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, INFO, J, NB
+* ..
+* .. Local Arrays ..
+ DOUBLE PRECISION A( NMAX, NMAX ), T( NMAX, NMAX ), W( NMAX ),
+ $ C( NMAX, NMAX ), TAU(NMAX)
+* ..
+* .. External Subroutines ..
+ EXTERNAL ALAESM, CHKXER, DGEQR,
+ $ DGEMQR, DGELQ, DGEMLQ
+* ..
+* .. Scalars in Common ..
+ LOGICAL LERR, OK
+ CHARACTER*32 SRNAMT
+ INTEGER INFOT, NOUT
+* ..
+* .. Common blocks ..
+ COMMON / INFOC / INFOT, NOUT, OK, LERR
+ COMMON / SRNAMC / SRNAMT
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC DBLE
+* ..
+* .. Executable Statements ..
+*
+ NOUT = NUNIT
+ WRITE( NOUT, FMT = * )
+*
+* Set the variables to innocuous values.
+*
+ DO J = 1, NMAX
+ DO I = 1, NMAX
+ A( I, J ) = 1.D0 / DBLE( I+J )
+ C( I, J ) = 1.D0 / DBLE( I+J )
+ T( I, J ) = 1.D0 / DBLE( I+J )
+ END DO
+ W( J ) = 0.D0
+ END DO
+ OK = .TRUE.
+*
+* Error exits for TS factorization
+*
+* DGEQR
+*
+ SRNAMT = 'DGEQR'
+ INFOT = 1
+ CALL DGEQR( -1, 0, A, 1, TAU, 1, W, 1, INFO )
+ CALL CHKXER( 'DGEQR', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DGEQR( 0, -1, A, 1, TAU, 1, W, 1, INFO )
+ CALL CHKXER( 'DGEQR', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL DGEQR( 1, 1, A, 0, TAU, 1, W, 1, INFO )
+ CALL CHKXER( 'DGEQR', INFOT, NOUT, LERR, OK )
+ INFOT = 6
+ CALL DGEQR( 3, 2, A, 3, TAU, 1, W, 1, INFO )
+ CALL CHKXER( 'DGEQR', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL DGEQR( 3, 2, A, 3, TAU, 7, W, 0, INFO )
+ CALL CHKXER( 'DGEQR', INFOT, NOUT, LERR, OK )
+*
+* DGEMQR
+*
+ TAU(1)=1
+ TAU(2)=1
+ SRNAMT = 'DGEMQR'
+ NB=1
+ INFOT = 1
+ CALL DGEMQR( '/', 'N', 0, 0, 0, A, 1, TAU, 1, C, 1, W, 1,INFO)
+ CALL CHKXER( 'DGEMQR', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DGEMQR( 'L', '/', 0, 0, 0, A, 1, TAU, 1, C, 1, W, 1,INFO)
+ CALL CHKXER( 'DGEMQR', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL DGEMQR( 'L', 'N', -1, 0, 0, A, 1, TAU, 1, C, 1, W,1,INFO)
+ CALL CHKXER( 'DGEMQR', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL DGEMQR( 'L', 'N', 0, -1, 0, A, 1, TAU, 1, C, 1, W,1,INFO)
+ CALL CHKXER( 'DGEMQR', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL DGEMQR( 'L', 'N', 0, 0, -1, A, 1, TAU, 1, C, 1, W,1,INFO)
+ CALL CHKXER( 'DGEMQR', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL DGEMQR( 'R', 'N', 0, 0, -1, A, 1, TAU, 1, C, 1, W,1,INFO)
+ CALL CHKXER( 'DGEMQR', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL DGEMQR( 'L', 'N', 2, 1, 0, A, 0, TAU, 1, C, 1, W, 1,INFO)
+ CALL CHKXER( 'DGEMQR', INFOT, NOUT, LERR, OK )
+ INFOT = 9
+ CALL DGEMQR( 'R', 'N', 2, 2, 1, A, 1, TAU, 0, C, 1, W, 1,INFO)
+ CALL CHKXER( 'DGEMQR', INFOT, NOUT, LERR, OK )
+ INFOT = 9
+ CALL DGEMQR( 'L', 'N', 2, 2, 1, A, 1, TAU, 0, C, 1, W, 1,INFO)
+ CALL CHKXER( 'DGEMQR', INFOT, NOUT, LERR, OK )
+ INFOT = 11
+ CALL DGEMQR( 'L', 'N', 2, 1, 1, A, 1, TAU, 6, C, 0, W, 1,INFO)
+ CALL CHKXER( 'DGEMQR', INFOT, NOUT, LERR, OK )
+ INFOT = 13
+ CALL DGEMQR( 'L', 'N', 2, 2, 1, A, 2, TAU, 6, C, 2, W, 0,INFO)
+ CALL CHKXER( 'DGEMQR', INFOT, NOUT, LERR, OK )
+*
+* DGELQ
+*
+ SRNAMT = 'DGELQ'
+ INFOT = 1
+ CALL DGELQ( -1, 0, A, 1, TAU, 1, W, 1, INFO )
+ CALL CHKXER( 'DGELQ', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DGELQ( 0, -1, A, 1, TAU, 1, W, 1, INFO )
+ CALL CHKXER( 'DGELQ', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL DGELQ( 1, 1, A, 0, TAU, 1, W, 1, INFO )
+ CALL CHKXER( 'DGELQ', INFOT, NOUT, LERR, OK )
+ INFOT = 6
+ CALL DGELQ( 2, 3, A, 3, TAU, 1, W, 1, INFO )
+ CALL CHKXER( 'DGELQ', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL DGELQ( 2, 3, A, 3, TAU, 7, W, 0, INFO )
+ CALL CHKXER( 'DGELQ', INFOT, NOUT, LERR, OK )
+*
+* DGEMLQ
+*
+ TAU(1)=1
+ TAU(2)=1
+ SRNAMT = 'DGEMLQ'
+ NB=1
+ INFOT = 1
+ CALL DGEMLQ( '/', 'N', 0, 0, 0, A, 1, TAU, 1, C, 1, W, 1,INFO)
+ CALL CHKXER( 'DGEMLQ', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DGEMLQ( 'L', '/', 0, 0, 0, A, 1, TAU, 1, C, 1, W, 1,INFO)
+ CALL CHKXER( 'DGEMLQ', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL DGEMLQ( 'L', 'N', -1, 0, 0, A, 1, TAU, 1, C, 1, W,1,INFO)
+ CALL CHKXER( 'DGEMLQ', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL DGEMLQ( 'L', 'N', 0, -1, 0, A, 1, TAU, 1, C, 1, W,1,INFO)
+ CALL CHKXER( 'DGEMLQ', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL DGEMLQ( 'L', 'N', 0, 0, -1, A, 1, TAU, 1, C, 1, W,1,INFO)
+ CALL CHKXER( 'DGEMLQ', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL DGEMLQ( 'R', 'N', 0, 0, -1, A, 1, TAU, 1, C, 1, W,1,INFO)
+ CALL CHKXER( 'DGEMLQ', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL DGEMLQ( 'L', 'N', 1, 2, 0, A, 0, TAU, 1, C, 1, W, 1,INFO)
+ CALL CHKXER( 'DGEMLQ', INFOT, NOUT, LERR, OK )
+ INFOT = 9
+ CALL DGEMLQ( 'R', 'N', 2, 2, 1, A, 1, TAU, 0, C, 1, W, 1,INFO)
+ CALL CHKXER( 'DGEMLQ', INFOT, NOUT, LERR, OK )
+ INFOT = 9
+ CALL DGEMLQ( 'L', 'N', 2, 2, 1, A, 1, TAU, 0, C, 1, W, 1,INFO)
+ CALL CHKXER( 'DGEMLQ', INFOT, NOUT, LERR, OK )
+ INFOT = 11
+ CALL DGEMLQ( 'L', 'N', 1, 2, 1, A, 1, TAU, 6, C, 0, W, 1,INFO)
+ CALL CHKXER( 'DGEMLQ', INFOT, NOUT, LERR, OK )
+ INFOT = 13
+ CALL DGEMLQ( 'L', 'N', 2, 2, 1, A, 2, TAU, 6, C, 2, W, 0,INFO)
+ CALL CHKXER( 'DGEMLQ', INFOT, NOUT, LERR, OK )
+*
+* Print a summary line.
+*
+ CALL ALAESM( PATH, OK, NOUT )
+*
+ RETURN
+*
+* End of DERRTSQR
+*
+ END
--- /dev/null
+*> \brief \b DLQT04
+*
+* =========== DOCUMENTATION ===========
+*
+* 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:
+* =============
+*>
+*> \verbatim
+*>
+*> DLQT04 tests DGELQT and DGEMLQT.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> Number of rows in test matrix.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> Number of columns in test matrix.
+*> \endverbatim
+*>
+*> \param[in] NB
+*> \verbatim
+*> NB is INTEGER
+*> Block size of test matrix. NB <= Min(M,N).
+*> \endverbatim
+*>
+*> \param[out] RESULT
+*> \verbatim
+*> RESULT is DOUBLE PRECISION array, dimension (6)
+*> Results of each of the six tests below.
+*>
+*> RESULT(1) = | A - L Q |
+*> 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(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.
+*
+*> \date April 2012
+*
+*> \ingroup double_lin
+*
+* =====================================================================
+ SUBROUTINE DLQT04(M,N,NB,RESULT)
+ IMPLICIT NONE
+*
+* -- LAPACK test routine (version 3.4.1) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* April 2012
+*
+* .. Scalar Arguments ..
+ INTEGER M, N, NB, LDT
+* .. Return values ..
+ DOUBLE PRECISION RESULT(6)
+*
+* =====================================================================
+*
+* ..
+* .. Local allocatable arrays
+ DOUBLE PRECISION, ALLOCATABLE :: AF(:,:), Q(:,:),
+ $ L(:,:), RWORK(:), WORK( : ), T(:,:),
+ $ CF(:,:), DF(:,:), A(:,:), C(:,:), D(:,:)
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE, ZERO
+ PARAMETER( ZERO = 0.0, ONE = 1.0 )
+* ..
+* .. Local Scalars ..
+ INTEGER INFO, J, K, LL, LWORK
+ DOUBLE PRECISION ANORM, EPS, RESID, CNORM, DNORM
+* ..
+* .. Local Arrays ..
+ INTEGER ISEED( 4 )
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMCH, DLANGE, DLANSY
+ LOGICAL LSAME
+ EXTERNAL DLAMCH, DLANGE, DLANSY, LSAME
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Data statements ..
+ DATA ISEED / 1988, 1989, 1990, 1991 /
+*
+ EPS = DLAMCH( 'Epsilon' )
+ K = MIN(M,N)
+ LL = MAX(M,N)
+ LWORK = MAX(2,LL)*MAX(2,LL)*NB
+*
+* 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),
+ $ D(N,M), DF(N,M) )
+*
+* Put random numbers into A and copy to AF
+*
+ LDT=NB
+ DO J=1,N
+ CALL DLARNV( 2, ISEED, M, A( 1, J ) )
+ END DO
+ CALL DLACPY( 'Full', M, N, A, M, AF, M )
+*
+* Factor the matrix A in the array AF.
+*
+ CALL DGELQT( M, N, NB, AF, M, T, LDT, WORK, INFO )
+*
+* 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,
+ $ WORK, INFO )
+*
+* Copy R
+*
+ CALL DLASET( 'Full', M, N, ZERO, ZERO, L, LL )
+ CALL DLACPY( 'Lower', M, N, AF, M, L, LL )
+*
+* Compute |L - A*Q'| / |A| and store in RESULT(1)
+*
+ CALL DGEMM( 'N', 'T', M, N, N, -ONE, A, M, Q, N, ONE, L, LL )
+ ANORM = DLANGE( '1', M, N, A, M, RWORK )
+ RESID = DLANGE( '1', M, N, L, LL, RWORK )
+ IF( ANORM.GT.ZERO ) THEN
+ RESULT( 1 ) = RESID / (EPS*MAX(1,M)*ANORM)
+ ELSE
+ RESULT( 1 ) = ZERO
+ END IF
+*
+* Compute |I - Q'*Q| and store in RESULT(2)
+*
+ CALL DLASET( 'Full', N, N, ZERO, ONE, L, LL )
+ CALL DSYRK( 'U', 'C', N, N, -ONE, Q, N, ONE, L, LL )
+ RESID = DLANSY( '1', 'Upper', N, L, LL, RWORK )
+ RESULT( 2 ) = RESID / (EPS*MAX(1,N))
+*
+* Generate random m-by-n matrix C and a copy CF
+*
+ DO J=1,M
+ CALL DLARNV( 2, ISEED, N, D( 1, J ) )
+ END DO
+ DNORM = DLANGE( '1', N, M, D, N, RWORK)
+ CALL DLACPY( 'Full', N, M, D, N, DF, N )
+*
+* Apply Q to C as Q*C
+*
+ CALL DGEMLQT( 'L', 'N', N, M, K, NB, AF, M, T, NB, DF, N,
+ $ WORK, INFO)
+*
+* Compute |Q*D - Q*D| / |D|
+*
+ CALL DGEMM( 'N', 'N', N, M, N, -ONE, Q, N, D, N, ONE, DF, N )
+ RESID = DLANGE( '1', N, M, DF, N, RWORK )
+ IF( DNORM.GT.ZERO ) THEN
+ RESULT( 3 ) = RESID / (EPS*MAX(1,M)*DNORM)
+ ELSE
+ RESULT( 3 ) = ZERO
+ END IF
+*
+* Copy D into DF again
+*
+ CALL DLACPY( 'Full', N, M, D, N, DF, N )
+*
+* Apply Q to D as QT*D
+*
+ CALL DGEMLQT( 'L', 'T', N, M, K, NB, AF, M, T, NB, DF, N,
+ $ WORK, INFO)
+*
+* Compute |QT*D - QT*D| / |D|
+*
+ CALL DGEMM( 'T', 'N', N, M, N, -ONE, Q, N, D, N, ONE, DF, N )
+ RESID = DLANGE( '1', N, M, DF, N, RWORK )
+ IF( DNORM.GT.ZERO ) THEN
+ RESULT( 4 ) = RESID / (EPS*MAX(1,M)*DNORM)
+ ELSE
+ RESULT( 4 ) = ZERO
+ END IF
+*
+* Generate random n-by-m matrix D and a copy DF
+*
+ DO J=1,N
+ CALL DLARNV( 2, ISEED, M, C( 1, J ) )
+ END DO
+ CNORM = DLANGE( '1', M, N, C, M, RWORK)
+ CALL DLACPY( 'Full', M, N, C, M, CF, M )
+*
+* Apply Q to C as C*Q
+*
+ CALL DGEMLQT( 'R', 'N', M, N, K, NB, AF, M, T, NB, CF, M,
+ $ WORK, INFO)
+*
+* Compute |C*Q - C*Q| / |C|
+*
+ CALL DGEMM( 'N', 'N', M, N, N, -ONE, C, M, Q, N, ONE, CF, M )
+ RESID = DLANGE( '1', N, M, DF, N, RWORK )
+ IF( CNORM.GT.ZERO ) THEN
+ RESULT( 5 ) = RESID / (EPS*MAX(1,M)*DNORM)
+ ELSE
+ RESULT( 5 ) = ZERO
+ END IF
+*
+* Copy C into CF again
+*
+ CALL DLACPY( 'Full', M, N, C, M, CF, M )
+*
+* Apply Q to D as D*QT
+*
+ CALL DGEMLQT( 'R', 'T', M, N, K, NB, AF, M, T, NB, CF, M,
+ $ WORK, INFO)
+*
+* Compute |C*QT - C*QT| / |C|
+*
+ CALL DGEMM( 'N', 'T', M, N, N, -ONE, C, M, Q, N, ONE, CF, M )
+ RESID = DLANGE( '1', M, N, CF, M, RWORK )
+ IF( CNORM.GT.ZERO ) THEN
+ RESULT( 6 ) = RESID / (EPS*MAX(1,M)*DNORM)
+ ELSE
+ RESULT( 6 ) = ZERO
+ END IF
+*
+* Deallocate all arrays
+*
+ DEALLOCATE ( A, AF, Q, L, RWORK, WORK, T, C, D, CF, DF)
+*
+ RETURN
+ END
+
--- /dev/null
+*> \brief \b DLQT05
+*
+* =========== DOCUMENTATION ===========
+*
+* 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:
+* =============
+*>
+*> \verbatim
+*>
+*> DQRT05 tests DTPLQT and DTPMLQT.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> Number of rows in lower part of the test matrix.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> Number of columns in test matrix.
+*> \endverbatim
+*>
+*> \param[in] L
+*> \verbatim
+*> L is INTEGER
+*> The number of rows of the upper trapezoidal part the
+*> lower test matrix. 0 <= L <= M.
+*> \endverbatim
+*>
+*> \param[in] NB
+*> \verbatim
+*> NB is INTEGER
+*> Block size of test matrix. NB <= N.
+*> \endverbatim
+*>
+*> \param[out] RESULT
+*> \verbatim
+*> RESULT is DOUBLE PRECISION array, dimension (6)
+*> Results of each of the six tests below.
+*>
+*> RESULT(1) = | A - Q R |
+*> 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(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.
+*
+*> \date April 2012
+*
+*> \ingroup double_lin
+*
+* =====================================================================
+ SUBROUTINE DLQT05(M,N,L,NB,RESULT)
+ IMPLICIT NONE
+*
+* -- LAPACK test routine (version 3.4.1) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* April 2012
+*
+* .. Scalar Arguments ..
+ INTEGER LWORK, M, N, L, NB, LDT
+* .. Return values ..
+ DOUBLE PRECISION RESULT(6)
+*
+* =====================================================================
+*
+* ..
+* .. Local allocatable arrays
+ DOUBLE PRECISION, ALLOCATABLE :: AF(:,:), Q(:,:),
+ $ R(:,:), RWORK(:), WORK( : ), T(:,:),
+ $ CF(:,:), DF(:,:), A(:,:), C(:,:), D(:,:)
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE, ZERO
+ PARAMETER( ZERO = 0.0, ONE = 1.0 )
+* ..
+* .. Local Scalars ..
+ INTEGER INFO, J, K, N2, NP1,i
+ DOUBLE PRECISION ANORM, EPS, RESID, CNORM, DNORM
+* ..
+* .. Local Arrays ..
+ INTEGER ISEED( 4 )
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMCH, DLANGE, DLANSY
+ LOGICAL LSAME
+ EXTERNAL DLAMCH, DLANGE, DLANSY, LSAME
+* ..
+* .. Data statements ..
+ DATA ISEED / 1988, 1989, 1990, 1991 /
+*
+ EPS = DLAMCH( 'Epsilon' )
+ K = M
+ N2 = M+N
+ IF( N.GT.0 ) THEN
+ NP1 = M+1
+ ELSE
+ NP1 = 1
+ END IF
+ LWORK = N2*N2*NB
+*
+* 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),
+ $ D(M,N2),DF(M,N2) )
+*
+* Put random stuff into A
+*
+ LDT=NB
+ CALL DLASET( 'Full', M, N2, ZERO, ZERO, A, M )
+ CALL DLASET( 'Full', NB, M, ZERO, ZERO, T, NB )
+ DO J=1,M
+ CALL DLARNV( 2, ISEED, M-J+1, A( J, J ) )
+ END DO
+ IF( N.GT.0 ) THEN
+ DO J=1,N-L
+ CALL DLARNV( 2, ISEED, M, A( 1, MIN(N+M,M+1) + J - 1 ) )
+ END DO
+ 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)
+ $ + J - 1 ) )
+ END DO
+ END IF
+*
+* Copy the matrix A to the array AF.
+*
+ CALL DLACPY( 'Full', M, N2, A, M, AF, M )
+*
+* Factor the matrix A in the array AF.
+*
+ CALL DTPLQT( M,N,L,NB,AF,M,AF(1,NP1),M,T,LDT,WORK,INFO)
+*
+* Generate the (M+N)-by-(M+N) matrix Q by applying H to I
+*
+ CALL DLASET( 'Full', N2, N2, ZERO, ONE, Q, N2 )
+ CALL DGEMLQT( 'L', 'N', N2, N2, K, NB, AF, M, T, LDT, Q, N2,
+ $ WORK, INFO )
+*
+* Copy L
+*
+ CALL DLASET( 'Full', N2, N2, ZERO, ZERO, R, N2 )
+ CALL DLACPY( 'Lower', M, N2, AF, M, R, N2 )
+*
+* Compute |L - A*Q*T| / |A| and store in RESULT(1)
+*
+ CALL DGEMM( 'N', 'T', M, N2, N2, -ONE, A, M, Q, N2, ONE, R, N2)
+ ANORM = DLANGE( '1', M, N2, A, M, RWORK )
+ RESID = DLANGE( '1', M, N2, R, N2, RWORK )
+ IF( ANORM.GT.ZERO ) THEN
+ RESULT( 1 ) = RESID / (EPS*ANORM*MAX(1,N2))
+ ELSE
+ RESULT( 1 ) = ZERO
+ END IF
+*
+* Compute |I - Q*Q'| and store in RESULT(2)
+*
+ CALL DLASET( 'Full', N2, N2, ZERO, ONE, R, N2 )
+ CALL DSYRK( 'U', 'N', N2, N2, -ONE, Q, N2, ONE, R, N2 )
+ RESID = DLANSY( '1', 'Upper', N2, R, N2, RWORK )
+ RESULT( 2 ) = RESID / (EPS*MAX(1,N2))
+*
+* Generate random m-by-n matrix C and a copy CF
+*
+ CALL DLASET( 'Full', N2, M, ZERO, ONE, C, N2 )
+ DO J=1,M
+ CALL DLARNV( 2, ISEED, N2, C( 1, J ) )
+ END DO
+ CNORM = DLANGE( '1', N2, M, C, N2, RWORK)
+ 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)
+*
+* Compute |Q*C - Q*C| / |C|
+*
+ CALL DGEMM( 'N', '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( 3 ) = RESID / (EPS*MAX(1,N2)*CNORM)
+ ELSE
+ RESULT( 3 ) = ZERO
+ END IF
+
+*
+* Copy C into CF again
+*
+ CALL DLACPY( 'Full', N2, M, C, N2, CF, N2 )
+*
+* 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)
+*
+* 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
+*
+* Generate random m-by-n matrix D and a copy DF
+*
+ DO J=1,N2
+ CALL DLARNV( 2, ISEED, M, D( 1, J ) )
+ END DO
+ DNORM = DLANGE( '1', M, N2, D, M, RWORK)
+ CALL DLACPY( 'Full', M, N2, D, M, DF, M )
+*
+* Apply Q to D as D*Q
+*
+ CALL DTPMLQT('R','N',M,N,K,L,NB,AF(1,NP1),M,T,LDT,DF,M,
+ $ DF(1,NP1),M,WORK,INFO)
+*
+* Compute |D*Q - D*Q| / |D|
+*
+ CALL DGEMM('N','N',M,N2,N2,-ONE,D,M,Q,N2,ONE,DF,M)
+ RESID = DLANGE('1',M, N2,DF,M,RWORK )
+ IF( CNORM.GT.ZERO ) THEN
+ RESULT( 5 ) = RESID / (EPS*MAX(1,N2)*DNORM)
+ ELSE
+ RESULT( 5 ) = ZERO
+ END IF
+*
+* Copy D into DF again
+*
+ CALL DLACPY('Full',M,N2,D,M,DF,M )
+*
+* 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)
+
+*
+* Compute |D*QT - D*QT| / |D|
+*
+ CALL DGEMM( 'N', 'T', M, N2, N2, -ONE, D, M, Q, N2, ONE, DF, M )
+ RESID = DLANGE( '1', M, N2, DF, M, RWORK )
+ IF( CNORM.GT.ZERO ) THEN
+ RESULT( 6 ) = RESID / (EPS*MAX(1,N2)*DNORM)
+ ELSE
+ RESULT( 6 ) = ZERO
+ END IF
+*
+* Deallocate all arrays
+*
+ DEALLOCATE ( A, AF, Q, R, RWORK, WORK, T, C, D, CF, DF)
+ RETURN
+ END
\ No newline at end of file
--- /dev/null
+*> \brief \b DTPLQT
+*
+* =========== DOCUMENTATION ===========
+*
+* 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">
+*> [TXT]</a>
+*> \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
+*> WY representation for Q.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows of the matrix B, and the order of the
+*> triangular matrix A.
+*> M >= 0.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of columns of the matrix B.
+*> N >= 0.
+*> \endverbatim
+*>
+*> \param[in] L
+*> \verbatim
+*> L is INTEGER
+*> The number of rows of the lower trapezoidal part of B.
+*> MIN(M,N) >= L >= 0. See Further Details.
+*> \endverbatim
+*>
+*> \param[in] MB
+*> \verbatim
+*> MB is INTEGER
+*> The block size to be used in the blocked QR. M >= MB >= 1.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is DOUBLE PRECISION array, dimension (LDA,N)
+*> On entry, the lower triangular N-by-N matrix A.
+*> On exit, the elements on and below the diagonal of the array
+*> contain the lower triangular matrix L.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in,out] B
+*> \verbatim
+*> B is DOUBLE PRECISION array, dimension (LDB,N)
+*> On entry, the 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
+*>
+*> \param[in] LDB
+*> \verbatim
+*> LDB is INTEGER
+*> The leading dimension of the array B. LDB >= max(1,M).
+*> \endverbatim
+*>
+*> \param[out] T
+*> \verbatim
+*> T is DOUBLE PRECISION array, dimension (LDT,N)
+*> 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
+*> The leading dimension of the array T. LDT >= MB.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is DOUBLE PRECISION array, dimension (MB*M)
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> < 0: if INFO = -i, the i-th argument had an illegal value
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2013
+*
+*> \ingroup doubleOTHERcomputational
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*>
+*> 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 ]
+*> [ 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.
+*>
+*> 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 ]
+*> [ A ] <- lower triangular N-by-N
+*> [ B ] <- M-by-N pentagonal
+*>
+*> so that W can be represented as
+*> [ 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 ]
+*> [ 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 number of blocks is B = ceiling(M/MB), where each
+*> 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
+*> for the last block) T's are stored in the MB-by-N matrix T as
+*>
+*> T = [T1 T2 ... TB].
+*> \endverbatim
+*>
+* =====================================================================
+ SUBROUTINE DTPLQT( M, N, L, MB, A, LDA, B, LDB, T, LDT, WORK,
+ $ INFO )
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2013
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, LDB, LDT, N, M, L, MB
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), B( LDB, * ), T( LDT, * ), WORK( * )
+* ..
+*
+* =====================================================================
+*
+* ..
+* .. Local Scalars ..
+ INTEGER I, IB, LB, NB, IINFO
+* ..
+* .. External Subroutines ..
+ EXTERNAL DTPLQT2, DTPRFB, XERBLA
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+ IF( M.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( L.LT.0 .OR. (L.GT.MIN(M,N) .AND. MIN(M,N).GE.0)) THEN
+ INFO = -3
+ ELSE IF( MB.LT.1 .OR. (MB.GT.M .AND. M.GT.0)) THEN
+ INFO = -4
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -6
+ ELSE IF( LDB.LT.MAX( 1, M ) ) THEN
+ INFO = -8
+ ELSE IF( LDT.LT.MB ) THEN
+ INFO = -10
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DTPLQT', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ 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 )
+ NB = MIN( N-L+I+IB-1, N )
+ IF( I.GE.L ) THEN
+ LB = 0
+ ELSE
+ LB = NB-N+L-I+1
+ END IF
+*
+ 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,
+ $ WORK, M-I-IB+1)
+ END IF
+ END DO
+ RETURN
+*
+* End of DTPLQT
+*
+ END
--- /dev/null
+*> \brief \b DTSQR01
+*
+* =========== DOCUMENTATION ===========
+*
+* 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:
+* =============
+*>
+*> \verbatim
+*>
+*> DTSQR01 tests DGEQR , DGELQ, DGEMLQ and DGEMQR.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] TSSW
+*> \verbatim
+*> TSSW is CHARACTER
+*> 'TS' for testing tall skinny QR
+*> and anything else for testing short wide LQ
+*> \endverbatim
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> Number of rows in test matrix.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> Number of columns in test matrix.
+*> \endverbatim
+*> \param[in] MB
+*> \verbatim
+*> MB is INTEGER
+*> Number of row in row block in test matrix.
+*> \endverbatim
+*>
+*> \param[in] NB
+*> \verbatim
+*> NB is INTEGER
+*> Number of columns in column block test matrix.
+*> \endverbatim
+*>
+*> \param[out] RESULT
+*> \verbatim
+*> RESULT is DOUBLE PRECISION array, dimension (6)
+*> Results of each of the six tests below.
+*>
+*> RESULT(1) = | A - Q R | or | A - L Q |
+*> 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(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.
+*
+*> \date April 2012
+*
+*> \ingroup double_lin
+*
+* =====================================================================
+ SUBROUTINE DTSQR01(TSSW, M, N, MB, NB, RESULT)
+ IMPLICIT NONE
+*
+* -- LAPACK test routine (version 3.4.1) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* April 2012
+*
+* .. Scalar Arguments ..
+ CHARACTER TSSW
+ INTEGER M, N, MB, NB
+* .. Return values ..
+ DOUBLE PRECISION RESULT(6)
+*
+* =====================================================================
+*
+* ..
+* .. Local allocatable arrays
+ DOUBLE PRECISION, ALLOCATABLE :: AF(:,:), Q(:,:),
+ $ R(:,:), RWORK(:), WORK( : ), T(:),
+ $ CF(:,:), DF(:,:), A(:,:), C(:,:), D(:,:), LQ(:,:)
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE, ZERO
+ PARAMETER( ZERO = 0.0, ONE = 1.0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL TESTZEROS, TS
+ INTEGER INFO, J, K, L, LWORK, LT ,MNB
+ DOUBLE PRECISION ANORM, EPS, RESID, CNORM, DNORM
+* ..
+* .. Local Arrays ..
+ INTEGER ISEED( 4 )
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMCH, DLANGE, DLANSY
+ LOGICAL LSAME
+ INTEGER ILAENV
+ EXTERNAL DLAMCH, DLANGE, DLANSY, LSAME, ILAENV
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* .. Scalars in Common ..
+ CHARACTER*32 srnamt
+* ..
+* .. Common blocks ..
+ COMMON / srnamc / srnamt
+* ..
+* .. Data statements ..
+ 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)
+ MNB = MAX ( MB, NB)
+ LWORK = MAX(3,L)*MNB
+ 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
+ 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),
+ $ D(N,M), DF(N,M), LQ(L,N) )
+*
+* Put random numbers into A and copy to AF
+*
+ DO J=1,N
+ CALL DLARNV( 2, ISEED, M, A( 1, J ) )
+ END DO
+ IF (TESTZEROS) THEN
+ IF (M.GE.4) THEN
+ DO J=1,N
+ CALL DLARNV( 2, ISEED, M/2, A( M/4, J ) )
+ END DO
+ END IF
+ END IF
+ CALL DLACPY( 'Full', M, N, A, M, AF, M )
+*
+ IF (TS) THEN
+*
+* Factor the matrix A in the array AF.
+*
+ srnamt = 'DGEQR'
+ CALL DGEQR( M, N, AF, M, T, LT, WORK, LWORK, INFO )
+*
+* Generate the m-by-m matrix Q
+*
+ CALL DLASET( 'Full', M, M, ZERO, ONE, Q, M )
+ srnamt = 'DGEMQR'
+ CALL DGEMQR( 'L', 'N', M, M, K, AF, M, T, LT, Q, M,
+ $ WORK, LWORK, INFO )
+*
+* Copy R
+*
+ CALL DLASET( 'Full', M, N, ZERO, ZERO, R, M )
+ CALL DLACPY( 'Upper', M, N, AF, M, R, M )
+*
+* Compute |R - Q'*A| / |A| and store in RESULT(1)
+*
+ CALL DGEMM( 'T', 'N', M, N, M, -ONE, Q, M, A, M, ONE, R, M )
+ ANORM = DLANGE( '1', M, N, A, M, RWORK )
+ RESID = DLANGE( '1', M, N, R, M, RWORK )
+ IF( ANORM.GT.ZERO ) THEN
+ RESULT( 1 ) = RESID / (EPS*MAX(1,M)*ANORM)
+ ELSE
+ RESULT( 1 ) = ZERO
+ END IF
+*
+* Compute |I - Q'*Q| and store in RESULT(2)
+*
+ CALL DLASET( 'Full', M, M, ZERO, ONE, R, M )
+ CALL DSYRK( 'U', 'C', M, M, -ONE, Q, M, ONE, R, M )
+ RESID = DLANSY( '1', 'Upper', M, R, M, RWORK )
+ RESULT( 2 ) = RESID / (EPS*MAX(1,M))
+*
+* Generate random m-by-n matrix C and a copy CF
+*
+ DO J=1,N
+ CALL DLARNV( 2, ISEED, M, C( 1, J ) )
+ END DO
+ CNORM = DLANGE( '1', M, N, C, M, RWORK)
+ CALL DLACPY( 'Full', M, N, C, M, CF, M )
+*
+* Apply Q to C as Q*C
+*
+ srnamt = 'DGEMQR'
+ CALL DGEMQR( 'L', 'N', M, N, K, AF, M, T, LT, CF, M,
+ $ WORK, LWORK, INFO)
+*
+* Compute |Q*C - Q*C| / |C|
+*
+ CALL DGEMM( 'N', 'N', M, N, M, -ONE, Q, M, C, M, ONE, CF, M )
+ RESID = DLANGE( '1', M, N, CF, M, RWORK )
+ IF( CNORM.GT.ZERO ) THEN
+ RESULT( 3 ) = RESID / (EPS*MAX(1,M)*CNORM)
+ ELSE
+ RESULT( 3 ) = ZERO
+ END IF
+*
+* Copy C into CF again
+*
+ CALL DLACPY( 'Full', M, N, C, M, CF, M )
+*
+* Apply Q to C as QT*C
+*
+ srnamt = 'DGEMQR'
+ CALL DGEMQR( 'L', 'T', M, N, K, AF, M, T, LT, CF, M,
+ $ WORK, LWORK, INFO)
+*
+* Compute |QT*C - QT*C| / |C|
+*
+ CALL DGEMM( 'T', 'N', M, N, M, -ONE, Q, M, C, M, ONE, CF, M )
+ RESID = DLANGE( '1', M, N, CF, M, RWORK )
+ IF( CNORM.GT.ZERO ) THEN
+ RESULT( 4 ) = RESID / (EPS*MAX(1,M)*CNORM)
+ ELSE
+ RESULT( 4 ) = ZERO
+ END IF
+*
+* Generate random n-by-m matrix D and a copy DF
+*
+ DO J=1,M
+ CALL DLARNV( 2, ISEED, N, D( 1, J ) )
+ END DO
+ DNORM = DLANGE( '1', N, M, D, N, RWORK)
+ CALL DLACPY( 'Full', N, M, D, N, DF, N )
+*
+* 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)
+*
+* Compute |D*Q - D*Q| / |D|
+*
+ CALL DGEMM( 'N', 'N', N, M, M, -ONE, D, N, Q, M, ONE, DF, N )
+ RESID = DLANGE( '1', N, M, DF, N, RWORK )
+ IF( DNORM.GT.ZERO ) THEN
+ RESULT( 5 ) = RESID / (EPS*MAX(1,M)*DNORM)
+ ELSE
+ RESULT( 5 ) = ZERO
+ END IF
+*
+* Copy D into DF again
+*
+ CALL DLACPY( 'Full', N, M, D, N, DF, N )
+*
+* Apply Q to D as D*QT
+*
+ CALL DGEMQR( 'R', 'T', N, M, K, AF, M, T, LT, DF, N,
+ $ WORK, LWORK, INFO)
+*
+* Compute |D*QT - D*QT| / |D|
+*
+ CALL DGEMM( 'N', 'T', N, M, M, -ONE, D, N, Q, M, ONE, DF, N )
+ RESID = DLANGE( '1', N, M, DF, N, RWORK )
+ IF( CNORM.GT.ZERO ) THEN
+ RESULT( 6 ) = RESID / (EPS*MAX(1,M)*DNORM)
+ ELSE
+ RESULT( 6 ) = ZERO
+ END IF
+*
+* Short and wide
+*
+ ELSE
+ srnamt = 'DGELQ'
+ CALL DGELQ( M, N, AF, M, T, LT, WORK, LWORK, INFO )
+*
+*
+* Generate the n-by-n matrix Q
+*
+ CALL DLASET( 'Full', N, N, ZERO, ONE, Q, N )
+ srnamt = 'DGEMLQ'
+ CALL DGEMLQ( 'R', 'N', N, N, K, AF, M, T, LT, Q, N,
+ $ WORK, LWORK, INFO )
+*
+* Copy R
+*
+ CALL DLASET( 'Full', M, N, ZERO, ZERO, LQ, L )
+ CALL DLACPY( 'Lower', M, N, AF, M, LQ, L )
+*
+* Compute |L - A*Q'| / |A| and store in RESULT(1)
+*
+ CALL DGEMM( 'N', 'T', M, N, N, -ONE, A, M, Q, N, ONE, LQ, L )
+ ANORM = DLANGE( '1', M, N, A, M, RWORK )
+ RESID = DLANGE( '1', M, N, LQ, L, RWORK )
+ IF( ANORM.GT.ZERO ) THEN
+ RESULT( 1 ) = RESID / (EPS*MAX(1,N)*ANORM)
+ ELSE
+ RESULT( 1 ) = ZERO
+ END IF
+*
+* Compute |I - Q'*Q| and store in RESULT(2)
+*
+ CALL DLASET( 'Full', N, N, ZERO, ONE, LQ, L )
+ CALL DSYRK( 'U', 'C', N, N, -ONE, Q, N, ONE, LQ, L )
+ RESID = DLANSY( '1', 'Upper', N, LQ, L, RWORK )
+ RESULT( 2 ) = RESID / (EPS*MAX(1,N))
+*
+* Generate random m-by-n matrix C and a copy CF
+*
+ DO J=1,M
+ CALL DLARNV( 2, ISEED, N, D( 1, J ) )
+ END DO
+ DNORM = DLANGE( '1', N, M, D, N, RWORK)
+ CALL DLACPY( 'Full', N, M, D, N, DF, N )
+*
+* Apply Q to C as Q*C
+*
+ CALL DGEMLQ( 'L', 'N', N, M, K, AF, M, T, LT, DF, N,
+ $ WORK, LWORK, INFO)
+*
+* Compute |Q*D - Q*D| / |D|
+*
+ CALL DGEMM( 'N', 'N', N, M, N, -ONE, Q, N, D, N, ONE, DF, N )
+ RESID = DLANGE( '1', N, M, DF, N, RWORK )
+ IF( DNORM.GT.ZERO ) THEN
+ RESULT( 3 ) = RESID / (EPS*MAX(1,N)*DNORM)
+ ELSE
+ RESULT( 3 ) = ZERO
+ END IF
+*
+* Copy D into DF again
+*
+ CALL DLACPY( 'Full', N, M, D, N, DF, N )
+*
+* Apply Q to D as QT*D
+*
+ CALL DGEMLQ( 'L', 'T', N, M, K, AF, M, T, LT, DF, N,
+ $ WORK, LWORK, INFO)
+*
+* Compute |QT*D - QT*D| / |D|
+*
+ CALL DGEMM( 'T', 'N', N, M, N, -ONE, Q, N, D, N, ONE, DF, N )
+ RESID = DLANGE( '1', N, M, DF, N, RWORK )
+ IF( DNORM.GT.ZERO ) THEN
+ RESULT( 4 ) = RESID / (EPS*MAX(1,N)*DNORM)
+ ELSE
+ RESULT( 4 ) = ZERO
+ END IF
+*
+* Generate random n-by-m matrix D and a copy DF
+*
+ DO J=1,N
+ CALL DLARNV( 2, ISEED, M, C( 1, J ) )
+ END DO
+ CNORM = DLANGE( '1', M, N, C, M, RWORK)
+ CALL DLACPY( 'Full', M, N, C, M, CF, M )
+*
+* Apply Q to C as C*Q
+*
+ CALL DGEMLQ( 'R', 'N', M, N, K, AF, M, T, LT, CF, M,
+ $ WORK, LWORK, INFO)
+*
+* Compute |C*Q - C*Q| / |C|
+*
+ CALL DGEMM( 'N', 'N', M, N, N, -ONE, C, M, Q, N, ONE, CF, M )
+ RESID = DLANGE( '1', N, M, DF, N, RWORK )
+ IF( CNORM.GT.ZERO ) THEN
+ RESULT( 5 ) = RESID / (EPS*MAX(1,N)*CNORM)
+ ELSE
+ RESULT( 5 ) = ZERO
+ END IF
+*
+* Copy C into CF again
+*
+ CALL DLACPY( 'Full', M, N, C, M, CF, M )
+*
+* Apply Q to D as D*QT
+*
+ CALL DGEMLQ( 'R', 'T', M, N, K, AF, M, T, LT, CF, M,
+ $ WORK, LWORK, INFO)
+*
+* Compute |C*QT - C*QT| / |C|
+*
+ CALL DGEMM( 'N', 'T', M, N, N, -ONE, C, M, Q, N, ONE, CF, M )
+ RESID = DLANGE( '1', M, N, CF, M, RWORK )
+ IF( CNORM.GT.ZERO ) THEN
+ RESULT( 6 ) = RESID / (EPS*MAX(1,N)*CNORM)
+ ELSE
+ RESULT( 6 ) = ZERO
+ END IF
+*
+ END IF
+*
+* Deallocate all arrays
+*
+ DEALLOCATE ( A, AF, Q, R, RWORK, WORK, T, C, D, CF, DF)
+*
+ RETURN
+ END
\ No newline at end of file
*
* =========== 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:
* ===========
*
* INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3,
* N4 )
-*
+*
* .. Scalar Arguments ..
* CHARACTER*( * ) NAME, OPTS
* INTEGER ISPEC, N1, N2, N3, N4
* ..
-*
+*
*
*> \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
*
*
* =====================================================================
*
+* .. Local Scalars ..
+ CHARACTER C1*1, C2*2, C4*2, C3*3, SUBNAM*6
* .. Intrinsic Functions ..
INTRINSIC INT, MIN, REAL
* ..
*
* Return a value from the common block.
*
- ILAENV = IPARMS( ISPEC )
+ IF ( NAME(2:6).EQ.'GEQR ' ) THEN
+ IF (N3.EQ.2) THEN
+ ILAENV = IPARMS ( 2 )
+ ELSE
+ ILAENV = IPARMS ( 1 )
+ END IF
+ ELSE IF ( NAME(2:6).EQ.'GELQ ' ) THEN
+ IF (N3.EQ.2) THEN
+ ILAENV = IPARMS ( 2 )
+ ELSE
+ ILAENV = IPARMS ( 1 )
+ END IF
+ ELSE
+ ILAENV = IPARMS( ISPEC )
+ END IF
*
ELSE IF( ISPEC.EQ.6 ) THEN
*
*
* =========== 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:
* ===========
*
* PROGRAM SCHKAA
-*
+*
*
*> \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 April 2012
*
WRITE( NOUT, FMT = 9988 )PATH
END IF
*
- ELSE IF( LSAMEN( 2, C2, 'SA' ) ) THEN
-*
-* SY: symmetric indefinite matrices,
-* with partial (Aasen's) pivoting algorithm
-*
- NTYPES = 10
- CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
-*
- IF( TSTCHK ) THEN
- CALL SCHKSY_AASEN( DOTYPE, NN, NVAL, NNB2, NBVAL2, NNS,
- $ 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 )
- ELSE
- WRITE( NOUT, FMT = 9989 )PATH
- END IF
-*
- IF( TSTDRV ) THEN
- CALL SDRVSY_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
- END IF
-*
ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN
*
* SP: symmetric indefinite packed matrices,
* QT: QRT routines for general matrices
*
IF( TSTCHK ) THEN
- CALL SCHKQRT( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
+ CALL SCHKQRT( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
$ NBVAL, NOUT )
ELSE
WRITE( NOUT, FMT = 9989 )PATH
* 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
+ END IF
+*
+ ELSE IF( LSAMEN( 2, C2, 'TQ' ) ) THEN
+*
+* TQ: LQT routines for general matrices
+*
+ IF( TSTCHK ) THEN
+ CALL SCHKLQT( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
+ $ NBVAL, NOUT )
+ ELSE
+ WRITE( NOUT, FMT = 9989 )PATH
+ END IF
+*
+ ELSE IF( LSAMEN( 2, C2, 'XQ' ) ) THEN
+*
+* XQ: LQT routines for triangular-pentagonal matrices
+*
+ IF( TSTCHK ) THEN
+ CALL SCHKLQTP( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
+ $ NBVAL, NOUT )
+ ELSE
+ WRITE( NOUT, FMT = 9989 )PATH
+ END IF
+*
+ ELSE IF( LSAMEN( 2, C2, 'TS' ) ) THEN
+*
+* TS: QR routines for tall-skinny matrices
+*
+ IF( TSTCHK ) THEN
+ CALL SCHKTSQR( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
$ NBVAL, NOUT )
ELSE
WRITE( NOUT, FMT = 9989 )PATH
--- /dev/null
+*> \brief \b SCHKLQT
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE SCHKLQT( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
+* NBVAL, NOUT )
+*
+* .. Scalar Arguments ..
+* LOGICAL TSTERR
+* INTEGER NM, NN, NNB, NOUT
+* REAL THRESH
+* ..
+* .. Array Arguments ..
+* INTEGER MVAL( * ), NBVAL( * ), NVAL( * )
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> SCHKLQT tests SGELQT and SGEMLQT.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] THRESH
+*> \verbatim
+*> THRESH is REAL
+*> The threshold value for the test ratios. A result is
+*> included in the output file if RESULT >= THRESH. To have
+*> every test ratio printed, use THRESH = 0.
+*> \endverbatim
+*>
+*> \param[in] TSTERR
+*> \verbatim
+*> TSTERR is LOGICAL
+*> Flag that indicates whether error exits are to be tested.
+*> \endverbatim
+*>
+*> \param[in] NM
+*> \verbatim
+*> NM is INTEGER
+*> The number of values of M contained in the vector MVAL.
+*> \endverbatim
+*>
+*> \param[in] MVAL
+*> \verbatim
+*> MVAL is INTEGER array, dimension (NM)
+*> The values of the matrix row dimension M.
+*> \endverbatim
+*>
+*> \param[in] NN
+*> \verbatim
+*> NN is INTEGER
+*> The number of values of N contained in the vector NVAL.
+*> \endverbatim
+*>
+*> \param[in] NVAL
+*> \verbatim
+*> NVAL is INTEGER array, dimension (NN)
+*> The values of the matrix column dimension N.
+*> \endverbatim
+*>
+*> \param[in] NNB
+*> \verbatim
+*> NNB is INTEGER
+*> The number of values of NB contained in the vector NBVAL.
+*> \endverbatim
+*>
+*> \param[in] NBVAL
+*> \verbatim
+*> NBVAL is INTEGER array, dimension (NBVAL)
+*> The values of the blocksize NB.
+*> \endverbatim
+*>
+*> \param[in] NOUT
+*> \verbatim
+*> NOUT is INTEGER
+*> The unit number for output.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \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,
+ $ NBVAL, NOUT )
+ IMPLICIT NONE
+*
+* -- LAPACK test routine (version 3.4.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2011
+*
+* .. Scalar Arguments ..
+ LOGICAL TSTERR
+ INTEGER NM, NN, NNB, NOUT
+ REAL THRESH
+* ..
+* .. Array Arguments ..
+ INTEGER MVAL( * ), NBVAL( * ), NVAL( * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER NTESTS
+ PARAMETER ( NTESTS = 6 )
+* ..
+* .. Local Scalars ..
+ CHARACTER*3 PATH
+ INTEGER I, J, K, T, M, N, NB, NFAIL, NERRS, NRUN,
+ $ MINMN
+*
+* .. Local Arrays ..
+ REAL RESULT( NTESTS )
+* ..
+* .. External Subroutines ..
+ EXTERNAL ALAERH, ALAHD, ALASUM, SERRLQT, SLQT04
+* ..
+* .. Scalars in Common ..
+ LOGICAL LERR, OK
+ CHARACTER*32 SRNAMT
+ INTEGER INFOT, NUNIT
+* ..
+* .. Common blocks ..
+ COMMON / INFOC / INFOT, NUNIT, OK, LERR
+ COMMON / SRNAMC / SRNAMT
+* ..
+* .. Executable Statements ..
+*
+* Initialize constants
+*
+ PATH( 1: 1 ) = 'S'
+ PATH( 2: 3 ) = 'TQ'
+ NRUN = 0
+ NFAIL = 0
+ NERRS = 0
+*
+* Test the error exits
+*
+ IF( TSTERR ) CALL SERRLQT( PATH, NOUT )
+ INFOT = 0
+*
+* Do for each value of M in MVAL.
+*
+ DO I = 1, NM
+ M = MVAL( I )
+*
+* Do for each value of N in NVAL.
+*
+ DO J = 1, NN
+ N = NVAL( J )
+*
+* Do for each possible value of NB
+*
+ MINMN = MIN( M, N )
+ DO K = 1, NNB
+ NB = NBVAL( K )
+*
+* Test DGELQT and DGEMLQT
+*
+ IF( (NB.LE.MINMN).AND.(NB.GT.0) ) THEN
+ CALL SLQT04( M, N, NB, RESULT )
+*
+* Print information about the tests that did not
+* pass the threshold.
+*
+ DO T = 1, NTESTS
+ IF( RESULT( T ).GE.THRESH ) THEN
+ IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
+ $ CALL ALAHD( NOUT, PATH )
+ WRITE( NOUT, FMT = 9999 )M, N, NB,
+ $ T, RESULT( T )
+ NFAIL = NFAIL + 1
+ END IF
+ END DO
+ NRUN = NRUN + NTESTS
+ END IF
+ END DO
+ END DO
+ END DO
+*
+* Print a summary of the results.
+*
+ CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
+*
+ 9999 FORMAT( ' M=', I5, ', N=', I5, ', NB=', I4,
+ $ ' test(', I2, ')=', G12.5 )
+ RETURN
+*
+* End of SCHKLQT
+*
+ END
--- /dev/null
+*> \brief \b SCHKLQTP
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE SCHKLQTP( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
+* NBVAL, NOUT )
+*
+* .. Scalar Arguments ..
+* LOGICAL TSTERR
+* INTEGER NM, NN, NNB, NOUT
+* REAL THRESH
+* ..
+* .. Array Arguments ..
+* INTEGER MVAL( * ), NBVAL( * ), NVAL( * )
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> SCHKLQTP tests STPLQT and STPMLQT.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] THRESH
+*> \verbatim
+*> THRESH is REAL
+*> The threshold value for the test ratios. A result is
+*> included in the output file if RESULT >= THRESH. To have
+*> every test ratio printed, use THRESH = 0.
+*> \endverbatim
+*>
+*> \param[in] TSTERR
+*> \verbatim
+*> TSTERR is LOGICAL
+*> Flag that indicates whether error exits are to be tested.
+*> \endverbatim
+*>
+*> \param[in] NM
+*> \verbatim
+*> NM is INTEGER
+*> The number of values of M contained in the vector MVAL.
+*> \endverbatim
+*>
+*> \param[in] MVAL
+*> \verbatim
+*> MVAL is INTEGER array, dimension (NM)
+*> The values of the matrix row dimension M.
+*> \endverbatim
+*>
+*> \param[in] NN
+*> \verbatim
+*> NN is INTEGER
+*> The number of values of N contained in the vector NVAL.
+*> \endverbatim
+*>
+*> \param[in] NVAL
+*> \verbatim
+*> NVAL is INTEGER array, dimension (NN)
+*> The values of the matrix column dimension N.
+*> \endverbatim
+*>
+*> \param[in] NNB
+*> \verbatim
+*> NNB is INTEGER
+*> The number of values of NB contained in the vector NBVAL.
+*> \endverbatim
+*>
+*> \param[in] NBVAL
+*> \verbatim
+*> NBVAL is INTEGER array, dimension (NBVAL)
+*> The values of the blocksize NB.
+*> \endverbatim
+*>
+*> \param[in] NOUT
+*> \verbatim
+*> NOUT is INTEGER
+*> The unit number for output.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \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,
+ $ NBVAL, NOUT )
+ IMPLICIT NONE
+*
+* -- LAPACK test routine (version 3.4.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2011
+*
+* .. Scalar Arguments ..
+ LOGICAL TSTERR
+ INTEGER NM, NN, NNB, NOUT
+ REAL THRESH
+* ..
+* .. Array Arguments ..
+ INTEGER MVAL( * ), NBVAL( * ), NVAL( * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER NTESTS
+ PARAMETER ( NTESTS = 6 )
+* ..
+* .. Local Scalars ..
+ CHARACTER*3 PATH
+ INTEGER I, J, K, L, T, M, N, NB, NFAIL, NERRS, NRUN,
+ $ MINMN
+* ..
+* .. Local Arrays ..
+ REAL RESULT( NTESTS )
+* ..
+* .. External Subroutines ..
+ EXTERNAL ALAERH, ALAHD, ALASUM, DERRLQTP, DLQT04
+* ..
+* .. Scalars in Common ..
+ LOGICAL LERR, OK
+ CHARACTER*32 SRNAMT
+ INTEGER INFOT, NUNIT
+* ..
+* .. Common blocks ..
+ COMMON / INFOC / INFOT, NUNIT, OK, LERR
+ COMMON / SRNAMC / SRNAMT
+* ..
+* .. Executable Statements ..
+*
+* Initialize constants
+*
+ PATH( 1: 1 ) = 'S'
+ PATH( 2: 3 ) = 'XQ'
+ NRUN = 0
+ NFAIL = 0
+ NERRS = 0
+*
+* Test the error exits
+*
+ IF( TSTERR ) CALL SERRLQTP( PATH, NOUT )
+ INFOT = 0
+*
+* Do for each value of M
+*
+ DO I = 1, NM
+ M = MVAL( I )
+*
+* Do for each value of N
+*
+ DO J = 1, NN
+ N = NVAL( J )
+*
+* Do for each value of L
+*
+ 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 )
+*
+* Print information about the tests that did not
+* pass the threshold.
+*
+ DO T = 1, NTESTS
+ IF( RESULT( T ).GE.THRESH ) THEN
+ IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
+ $ CALL ALAHD( NOUT, PATH )
+ WRITE( NOUT, FMT = 9999 )M, N, NB, L,
+ $ T, RESULT( T )
+ NFAIL = NFAIL + 1
+ END IF
+ END DO
+ NRUN = NRUN + NTESTS
+ END IF
+ END DO
+ END DO
+ END DO
+ END DO
+*
+* Print a summary of the results.
+*
+ CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
+*
+ 9999 FORMAT( ' M=', I5, ', N=', I5, ', NB=', I4,' L=', I4,
+ $ ' test(', I2, ')=', G12.5 )
+ RETURN
+*
+* End of SCHKQRTP
+*
+ END
--- /dev/null
+*> \brief \b SCHKQRT
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE SCHKTSQR( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
+* NBVAL, NOUT )
+*
+* .. Scalar Arguments ..
+* LOGICAL TSTERR
+* INTEGER NM, NN, NNB, NOUT
+* REAL THRESH
+* ..
+* .. Array Arguments ..
+* INTEGER MVAL( * ), NBVAL( * ), NVAL( * )
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> SCHKTSQR tests SGETSQR and SORMTSQR.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] THRESH
+*> \verbatim
+*> THRESH is REAL
+*> The threshold value for the test ratios. A result is
+*> included in the output file if RESULT >= THRESH. To have
+*> every test ratio printed, use THRESH = 0.
+*> \endverbatim
+*>
+*> \param[in] TSTERR
+*> \verbatim
+*> TSTERR is LOGICAL
+*> Flag that indicates whether error exits are to be tested.
+*> \endverbatim
+*>
+*> \param[in] NM
+*> \verbatim
+*> NM is INTEGER
+*> The number of values of M contained in the vector MVAL.
+*> \endverbatim
+*>
+*> \param[in] MVAL
+*> \verbatim
+*> MVAL is INTEGER array, dimension (NM)
+*> The values of the matrix row dimension M.
+*> \endverbatim
+*>
+*> \param[in] NN
+*> \verbatim
+*> NN is INTEGER
+*> The number of values of N contained in the vector NVAL.
+*> \endverbatim
+*>
+*> \param[in] NVAL
+*> \verbatim
+*> NVAL is INTEGER array, dimension (NN)
+*> The values of the matrix column dimension N.
+*> \endverbatim
+*>
+*> \param[in] NNB
+*> \verbatim
+*> NNB is INTEGER
+*> The number of values of NB contained in the vector NBVAL.
+*> \endverbatim
+*>
+*> \param[in] NBVAL
+*> \verbatim
+*> NBVAL is INTEGER array, dimension (NBVAL)
+*> The values of the blocksize NB.
+*> \endverbatim
+*>
+*> \param[in] NOUT
+*> \verbatim
+*> NOUT is INTEGER
+*> The unit number for output.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \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,
+ $ NBVAL, NOUT )
+ IMPLICIT NONE
+*
+* -- LAPACK test routine (version 3.4.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2011
+*
+* .. Scalar Arguments ..
+ LOGICAL TSTERR
+ INTEGER NM, NN, NNB, NOUT
+ REAL THRESH
+* ..
+* .. Array Arguments ..
+ INTEGER MVAL( * ), NBVAL( * ), NVAL( * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER NTESTS
+ PARAMETER ( NTESTS = 6 )
+* ..
+* .. Local Scalars ..
+ CHARACTER*3 PATH
+ INTEGER I, J, K, T, M, N, NB, NFAIL, NERRS, NRUN, INB,
+ $ MINMN, MB, IMB
+*
+* .. Local Arrays ..
+ REAL RESULT( NTESTS )
+* ..
+* .. External Subroutines ..
+ EXTERNAL ALAERH, ALAHD, ALASUM, SERRTSQR,
+ $ STSQR01, XLAENV
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Scalars in Common ..
+ LOGICAL LERR, OK
+ CHARACTER*32 SRNAMT
+ INTEGER INFOT, NUNIT
+* ..
+* .. Common blocks ..
+ COMMON / INFOC / INFOT, NUNIT, OK, LERR
+ COMMON / SRNAMC / SRNAMT
+* ..
+* .. Executable Statements ..
+*
+* Initialize constants
+*
+ PATH( 1: 1 ) = 'S'
+ PATH( 2: 3 ) = 'TS'
+ NRUN = 0
+ NFAIL = 0
+ NERRS = 0
+*
+* Test the error exits
+*
+ IF( TSTERR ) CALL SERRTSQR( PATH, NOUT )
+ INFOT = 0
+*
+* Do for each value of M in MVAL.
+*
+ DO I = 1, NM
+ M = MVAL( I )
+*
+* Do for each value of N in NVAL.
+*
+ DO J = 1, NN
+ N = NVAL( J )
+ IF (MIN(M,N).NE.0) THEN
+ DO INB = 1, NNB
+ MB = NBVAL( INB )
+ CALL XLAENV( 1, MB )
+ DO IMB = 1, NNB
+ NB = NBVAL( IMB )
+ CALL XLAENV( 2, NB )
+*
+* Test SGEQR and SGEMQR
+*
+ CALL STSQR01('TS', M, N, MB, NB, RESULT )
+*
+* Print information about the tests that did not
+* pass the threshold.
+*
+ DO T = 1, NTESTS
+ IF( RESULT( T ).GE.THRESH ) THEN
+ IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
+ $ CALL ALAHD( NOUT, PATH )
+ WRITE( NOUT, FMT = 9999 )M, N, MB, NB,
+ $ T, RESULT( T )
+ NFAIL = NFAIL + 1
+ END IF
+ END DO
+ NRUN = NRUN + NTESTS
+ END DO
+ END DO
+ END IF
+ END DO
+ END DO
+*
+* Do for each value of M in MVAL.
+*
+ DO I = 1, NM
+ M = MVAL( I )
+*
+* Do for each value of N in NVAL.
+*
+ DO J = 1, NN
+ N = NVAL( J )
+ IF (MIN(M,N).NE.0) THEN
+ DO INB = 1, NNB
+ MB = NBVAL( INB )
+ CALL XLAENV( 1, MB )
+ DO IMB = 1, NNB
+ NB = NBVAL( IMB )
+ CALL XLAENV( 2, NB )
+*
+* Test SGEQR and SGEMQR
+*
+ CALL STSQR01('SW', M, N, MB, NB, RESULT )
+*
+* Print information about the tests that did not
+* pass the threshold.
+*
+ DO T = 1, NTESTS
+ IF( RESULT( T ).GE.THRESH ) THEN
+ IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
+ $ CALL ALAHD( NOUT, PATH )
+ WRITE( NOUT, FMT = 9998 )M, N, MB, NB,
+ $ T, RESULT( T )
+ NFAIL = NFAIL + 1
+ END IF
+ END DO
+ NRUN = NRUN + NTESTS
+ END DO
+ END DO
+ END IF
+ END DO
+ END DO
+*
+* Print a summary of the results.
+*
+ CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
+*
+ 9999 FORMAT( 'TS: M=', I5, ', N=', I5, ', MB=', I5,
+ $ ', NB=', I5,' test(', I2, ')=', G12.5 )
+ 9998 FORMAT( 'SW: M=', I5, ', N=', I5, ', MB=', I5,
+ $ ', NB=', I5,' test(', I2, ')=', G12.5 )
+ RETURN
+*
+* End of SCHKQRT
+*
+ 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 SDRVLS( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, NNB,
* NBVAL, NXVAL, THRESH, TSTERR, A, COPYA, B,
* COPYB, C, S, COPYS, WORK, IWORK, NOUT )
-*
+*
* .. Scalar Arguments ..
* LOGICAL TSTERR
* INTEGER NM, NN, NNB, NNS, NOUT
* REAL A( * ), B( * ), C( * ), COPYA( * ), COPYB( * ),
* $ COPYS( * ), S( * ), WORK( * )
* ..
-*
+*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
-*> SDRVLS tests the least squares driver routines SGELS, SGELSS, SGELSY
+*> SDRVLS tests the least squares driver routines SGELS, SGETSLS, SGELSS, SGELSY,
*> and SGELSD.
*> \endverbatim
*
*> .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
*> The matrix of type j is generated as follows:
*> j=1: A = U*D*V where U and V are random orthogonal matrices
-*> and D has random entries (> 0.1) taken from a uniform
+*> and D has random entries (> 0.1) taken from a uniform
*> distribution (0,1). A is full rank.
*> j=2: The same of 1, but A is scaled up.
*> j=3: The same of 1, but A is scaled down.
*> j=4: A = U*D*V where U and V are random orthogonal matrices
*> and D has 3*min(M,N)/4 random entries (> 0.1) taken
*> from a uniform distribution (0,1) and the remaining
-*> entries set to 0. A is rank-deficient.
+*> entries set to 0. A is rank-deficient.
*> j=5: The same of 4, but A is scaled up.
*> j=6: The same of 5, but A is scaled down.
*> \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
*
-*> \ingroup single_lin
+*> \ingroup double_lin
*
* =====================================================================
SUBROUTINE SDRVLS( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, NNB,
*
* .. Parameters ..
INTEGER NTESTS
- PARAMETER ( NTESTS = 14 )
+ PARAMETER ( NTESTS = 16 )
INTEGER SMLSIZ
PARAMETER ( SMLSIZ = 25 )
REAL ONE, TWO, ZERO
* .. Local Scalars ..
CHARACTER TRANS
CHARACTER*3 PATH
- INTEGER CRANK, I, IM, 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
+ INTEGER CRANK, I, IM, 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
* ..
* .. Local Arrays ..
* .. External Subroutines ..
EXTERNAL ALAERH, ALAHD, ALASVM, SAXPY, SERRLS, SGELS,
$ SGELSD, SGELSS, SGELSY, SGEMM, SLACPY,
- $ SLARNV, SQRT13, SQRT15, SQRT16, SSCAL,
+ $ SLARNV, SLASRT, SQRT13, SQRT15, SQRT16, SSCAL,
$ XLAENV
* ..
* .. Intrinsic Functions ..
- INTRINSIC INT, LOG, MAX, MIN, REAL, SQRT
+ INTRINSIC REAL, INT, LOG, MAX, MIN, SQRT
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
*
* Initialize constants and the random number seed.
*
- PATH( 1: 1 ) = 'Single precision'
+ PATH( 1: 1 ) = 'SINGLE PRECISION'
PATH( 2: 3 ) = 'LS'
NRUN = 0
NFAIL = 0
IF( ( NM.EQ.0 .OR. NN.EQ.0 ) .AND. THRESH.EQ.ZERO )
$ CALL ALAHD( NOUT, PATH )
INFOT = 0
+ CALL XLAENV( 2, 2 )
+ CALL XLAENV( 9, SMLSIZ )
*
DO 150 IM = 1, NM
M = MVAL( IM )
*
DO 140 IN = 1, NN
N = NVAL( IN )
- MNMIN = MIN( M, N )
+ MNMIN = MAX(MIN( M, N ),1)
LDB = MAX( 1, M, N )
+ MB = (MNMIN+1)
+ IF(MINMN.NE.MB) THEN
+ LWTS = (((LDB-MB)/(MB-MNMIN))*MNMIN+MNMIN*2)*MB+5
+ ELSE
+ LWTS = 2*MINMN+5
+ END IF
*
DO 130 INS = 1, NNS
NRHS = NSVAL( INS )
$ REAL( SMLSIZ+1 ) ) / LOG( TWO ) ) + 1, 0 )
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 )
+ $ 8*MNMIN*NLVL+MNMIN*NRHS+(SMLSIZ+1)**2,LWTS)
+ $
*
DO 120 IRANK = 1, 2
DO 110 ISCALE = 1, 3
NRUN = NRUN + 2
30 CONTINUE
40 CONTINUE
+*
+*
+* Test SGETSLS
+*
+* Generate a matrix of scaling type ISCALE
+*
+ CALL SQRT13( ISCALE, M, N, COPYA, LDA, NORMA,
+ $ ISEED )
+ DO 65 INB = 1, NNB
+ MB = NBVAL( INB )
+ CALL XLAENV( 1, MB )
+ DO 62 IMB = 1, NNB
+ NB = NBVAL( IMB )
+ CALL XLAENV( 2, NB )
+*
+ DO 60 ITRAN = 1, 2
+ IF( ITRAN.EQ.1 ) THEN
+ TRANS = 'N'
+ NROWS = M
+ NCOLS = N
+ ELSE
+ TRANS = 'T'
+ NROWS = N
+ NCOLS = M
+ END IF
+ LDWORK = MAX( 1, NCOLS )
+*
+* Set up a consistent rhs
+*
+ IF( NCOLS.GT.0 ) THEN
+ CALL SLARNV( 2, ISEED, NCOLS*NRHS,
+ $ WORK )
+ CALL SSCAL( NCOLS*NRHS,
+ $ ONE / REAL( NCOLS ), WORK,
+ $ 1 )
+ END IF
+ CALL SGEMM( TRANS, 'No transpose', NROWS,
+ $ NRHS, NCOLS, ONE, COPYA, LDA,
+ $ WORK, LDWORK, ZERO, B, LDB )
+ CALL SLACPY( 'Full', NROWS, NRHS, B, LDB,
+ $ COPYB, LDB )
+*
+* Solve LS or overdetermined system
+*
+ IF( M.GT.0 .AND. N.GT.0 ) THEN
+ CALL SLACPY( 'Full', M, N, COPYA, LDA,
+ $ A, LDA )
+ CALL SLACPY( 'Full', NROWS, NRHS,
+ $ COPYB, LDB, B, LDB )
+ END IF
+ SRNAMT = 'SGETSLS '
+ CALL SGETSLS( TRANS, M, N, NRHS, A,
+ $ LDA, B, LDB, WORK, LWORK, INFO )
+ IF( INFO.NE.0 )
+ $ CALL ALAERH( PATH, 'SGETSLS ', INFO, 0,
+ $ TRANS, M, N, NRHS, -1, NB,
+ $ ITYPE, NFAIL, NERRS,
+ $ NOUT )
+*
+* Check correctness of results
+*
+ LDWORK = MAX( 1, NROWS )
+ IF( NROWS.GT.0 .AND. NRHS.GT.0 )
+ $ CALL SLACPY( 'Full', NROWS, NRHS,
+ $ COPYB, LDB, C, LDB )
+ CALL SQRT16( TRANS, M, N, NRHS, COPYA,
+ $ LDA, B, LDB, C, LDB, WORK,
+ $ RESULT( 15 ) )
+*
+ IF( ( ITRAN.EQ.1 .AND. M.GE.N ) .OR.
+ $ ( ITRAN.EQ.2 .AND. M.LT.N ) ) THEN
+*
+* Solving LS system
+*
+ RESULT( 16 ) = SQRT17( TRANS, 1, M, N,
+ $ NRHS, COPYA, LDA, B, LDB,
+ $ COPYB, LDB, C, WORK,
+ $ LWORK )
+ ELSE
+*
+* Solving overdetermined system
+*
+ RESULT( 16 ) = SQRT14( TRANS, M, N,
+ $ NRHS, COPYA, LDA, B, LDB,
+ $ WORK, LWORK )
+ END IF
+*
+* Print information about the tests that
+* did not pass the threshold.
+*
+ DO 50 K = 15, 16
+ IF( RESULT( K ).GE.THRESH ) THEN
+ IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
+ $ CALL ALAHD( NOUT, PATH )
+ WRITE( NOUT, FMT = 9997 )TRANS, M,
+ $ N, NRHS, MB, NB, ITYPE, K,
+ $ RESULT( K )
+ NFAIL = NFAIL + 1
+ END IF
+ 50 CONTINUE
+ NRUN = NRUN + 2
+ 60 CONTINUE
+ 62 CONTINUE
+ 65 CONTINUE
END IF
*
* Generate a matrix of scaling type ISCALE and rank
* Print information about the tests that did not
* pass the threshold.
*
- DO 90 K = 3, NTESTS
+ DO 90 K = 3, 14
IF( RESULT( K ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
NFAIL = NFAIL + 1
END IF
90 CONTINUE
- NRUN = NRUN + 12
+ NRUN = NRUN + 12
*
100 CONTINUE
110 CONTINUE
$ ', 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,
+ $ ', test(', I2, ')=', G12.5 )
RETURN
*
* End of SDRVLS
--- /dev/null
+*> \brief \b SERRLQT
+*
+* =========== DOCUMENTATION ===========
+*
+* 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:
+* =============
+*>
+*> \verbatim
+*>
+*> DERRLQT tests the error exits for the DOUBLE PRECISION routines
+*> that use the LQT decomposition of a general matrix.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] PATH
+*> \verbatim
+*> PATH is CHARACTER*3
+*> The LAPACK path name for the routines to be tested.
+*> \endverbatim
+*>
+*> \param[in] NUNIT
+*> \verbatim
+*> NUNIT is INTEGER
+*> The unit number for output.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2011
+*
+*> \ingroup double_lin
+*
+* =====================================================================
+ SUBROUTINE SERRLQT( PATH, NUNIT )
+ IMPLICIT NONE
+*
+* -- LAPACK test routine (version 3.4.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2011
+*
+* .. Scalar Arguments ..
+ CHARACTER*3 PATH
+ INTEGER NUNIT
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER NMAX
+ PARAMETER ( NMAX = 2 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, INFO, J
+* ..
+* .. Local Arrays ..
+ REAL A( NMAX, NMAX ), T( NMAX, NMAX ), W( NMAX ),
+ $ C( NMAX, NMAX )
+* ..
+* .. External Subroutines ..
+ EXTERNAL ALAESM, CHKXER, SGELQT3, SGELQT,
+ $ SGEMLQT
+* ..
+* .. Scalars in Common ..
+ LOGICAL LERR, OK
+ CHARACTER*32 SRNAMT
+ INTEGER INFOT, NOUT
+* ..
+* .. Common blocks ..
+ COMMON / INFOC / INFOT, NOUT, OK, LERR
+ COMMON / SRNAMC / SRNAMT
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC REAL
+* ..
+* .. Executable Statements ..
+*
+ NOUT = NUNIT
+ WRITE( NOUT, FMT = * )
+*
+* Set the variables to innocuous values.
+*
+ DO J = 1, NMAX
+ DO I = 1, NMAX
+ A( I, J ) = 1.D0 / REAL( I+J )
+ C( I, J ) = 1.D0 / REAL( I+J )
+ T( I, J ) = 1.D0 / REAL( I+J )
+ END DO
+ W( J ) = 0.D0
+ END DO
+ OK = .TRUE.
+*
+* Error exits for LQT factorization
+*
+* SGELQT
+*
+ SRNAMT = 'SGELQT'
+ INFOT = 1
+ CALL SGELQT( -1, 0, 1, A, 1, T, 1, W, INFO )
+ CALL CHKXER( 'SGELQT', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL SGELQT( 0, -1, 1, A, 1, T, 1, W, INFO )
+ CALL CHKXER( 'SGELQT', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL SGELQT( 0, 0, 0, A, 1, T, 1, W, INFO )
+ CALL CHKXER( 'SGELQT', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL SGELQT( 2, 1, 1, A, 1, T, 1, W, INFO )
+ CALL CHKXER( 'SGELQT', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL SGELQT( 2, 2, 2, A, 2, T, 1, W, INFO )
+ CALL CHKXER( 'SGELQT', INFOT, NOUT, LERR, OK )
+*
+* SGELQT3
+*
+ SRNAMT = 'SGELQT3'
+ INFOT = 1
+ CALL SGELQT3( -1, 0, A, 1, T, 1, INFO )
+ CALL CHKXER( 'SGELQT3', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL SGELQT3( 0, -1, A, 1, T, 1, INFO )
+ CALL CHKXER( 'SGELQT3', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL SGELQT3( 2, 2, A, 1, T, 1, INFO )
+ CALL CHKXER( 'SGELQT3', INFOT, NOUT, LERR, OK )
+ INFOT = 6
+ CALL SGELQT3( 2, 2, A, 2, T, 1, INFO )
+ CALL CHKXER( 'SGELQT3', INFOT, NOUT, LERR, OK )
+*
+* SGEMLQT
+*
+ SRNAMT = 'SGEMLQT'
+ INFOT = 1
+ CALL SGEMLQT( '/', 'N', 0, 0, 0, 1, A, 1, T, 1, C, 1, W, INFO )
+ CALL CHKXER( 'SGEMLQT', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL SGEMLQT( 'L', '/', 0, 0, 0, 1, A, 1, T, 1, C, 1, W, INFO )
+ CALL CHKXER( 'SGEMLQT', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL SGEMLQT( 'L', 'N', -1, 0, 0, 1, A, 1, T, 1, C, 1, W, INFO )
+ CALL CHKXER( 'SGEMLQT', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL SGEMLQT( 'L', 'N', 0, -1, 0, 1, A, 1, T, 1, C, 1, W, INFO )
+ CALL CHKXER( 'SGEMLQT', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL SGEMLQT( 'L', 'N', 0, 0, -1, 1, A, 1, T, 1, C, 1, W, INFO )
+ CALL CHKXER( 'SGEMLQT', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL SGEMLQT( 'R', 'N', 0, 0, -1, 1, A, 1, T, 1, C, 1, W, INFO )
+ CALL CHKXER( 'SGEMLQT', INFOT, NOUT, LERR, OK )
+ INFOT = 6
+ CALL SGEMLQT( 'L', 'N', 0, 0, 0, 0, A, 1, T, 1, C, 1, W, INFO )
+ CALL CHKXER( 'SGEMLQT', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL SGEMLQT( 'R', 'N', 2, 2, 2, 1, A, 1, T, 1, C, 1, W, INFO )
+ CALL CHKXER( 'SGEMLQT', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL SGEMLQT( 'L', 'N', 2, 2, 2, 1, A, 1, T, 1, C, 1, W, INFO )
+ CALL CHKXER( 'SGEMLQT', INFOT, NOUT, LERR, OK )
+ INFOT = 10
+ CALL SGEMLQT( 'R', 'N', 1, 1, 1, 1, A, 1, T, 0, C, 1, W, INFO )
+ CALL CHKXER( 'SGEMLQT', INFOT, NOUT, LERR, OK )
+ INFOT = 12
+ CALL SGEMLQT( 'L', 'N', 1, 1, 1, 1, A, 1, T, 1, C, 0, W, INFO )
+ CALL CHKXER( 'SGEMLQT', INFOT, NOUT, LERR, OK )
+*
+* Print a summary line.
+*
+ CALL ALAESM( PATH, OK, NOUT )
+*
+ RETURN
+*
+* End of SERRLQT
+*
+ END
--- /dev/null
+*> \brief \b DERRLQTP
+*
+* =========== DOCUMENTATION ===========
+*
+* 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:
+* =============
+*>
+*> \verbatim
+*>
+*> SERRLQTP tests the error exits for the REAL routines
+*> that use the LQT decomposition of a triangular-pentagonal matrix.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] PATH
+*> \verbatim
+*> PATH is CHARACTER*3
+*> The LAPACK path name for the routines to be tested.
+*> \endverbatim
+*>
+*> \param[in] NUNIT
+*> \verbatim
+*> NUNIT is INTEGER
+*> The unit number for output.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2011
+*
+*> \ingroup double_lin
+*
+* =====================================================================
+ SUBROUTINE SERRLQTP( PATH, NUNIT )
+ IMPLICIT NONE
+*
+* -- LAPACK test routine (version 3.4.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2011
+*
+* .. Scalar Arguments ..
+ CHARACTER*3 PATH
+ INTEGER NUNIT
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER NMAX
+ PARAMETER ( NMAX = 2 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, INFO, J
+* ..
+* .. Local Arrays ..
+ REAL A( NMAX, NMAX ), T( NMAX, NMAX ), W( NMAX ),
+ $ B( NMAX, NMAX ), C( NMAX, NMAX )
+* ..
+* .. External Subroutines ..
+ EXTERNAL ALAESM, CHKXER, STPLQT2, STPLQT,
+ $ STPMLQT
+* ..
+* .. Scalars in Common ..
+ LOGICAL LERR, OK
+ CHARACTER*32 SRNAMT
+ INTEGER INFOT, NOUT
+* ..
+* .. Common blocks ..
+ COMMON / INFOC / INFOT, NOUT, OK, LERR
+ COMMON / SRNAMC / SRNAMT
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC REAL
+* ..
+* .. Executable Statements ..
+*
+ NOUT = NUNIT
+ WRITE( NOUT, FMT = * )
+*
+* Set the variables to innocuous values.
+*
+ DO J = 1, NMAX
+ DO I = 1, NMAX
+ A( I, J ) = 1.D0 / REAL( I+J )
+ C( I, J ) = 1.D0 / REAL( I+J )
+ T( I, J ) = 1.D0 / REAL( I+J )
+ END DO
+ W( J ) = 0.0
+ END DO
+ OK = .TRUE.
+*
+* Error exits for TPLQT factorization
+*
+* STPLQT
+*
+ SRNAMT = 'STPLQT'
+ INFOT = 1
+ CALL STPLQT( -1, 1, 0, 1, A, 1, B, 1, T, 1, W, INFO )
+ CALL CHKXER( 'STPLQT', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL STPLQT( 1, -1, 0, 1, A, 1, B, 1, T, 1, W, INFO )
+ CALL CHKXER( 'STPLQT', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL STPLQT( 0, 1, -1, 1, A, 1, B, 1, T, 1, W, INFO )
+ CALL CHKXER( 'STPLQT', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL STPLQT( 0, 1, 1, 1, A, 1, B, 1, T, 1, W, INFO )
+ CALL CHKXER( 'STPLQT', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL STPLQT( 0, 1, 0, 0, A, 1, B, 1, T, 1, W, INFO )
+ CALL CHKXER( 'STPLQT', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL STPLQT( 1, 1, 0, 2, A, 1, B, 1, T, 1, W, INFO )
+ CALL CHKXER( 'STPLQT', INFOT, NOUT, LERR, OK )
+ INFOT = 6
+ CALL STPLQT( 2, 1, 0, 2, A, 1, B, 1, T, 1, W, INFO )
+ CALL CHKXER( 'STPLQT', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL STPLQT( 2, 1, 0, 1, A, 2, B, 1, T, 1, W, INFO )
+ CALL CHKXER( 'STPLQT', INFOT, NOUT, LERR, OK )
+ INFOT = 10
+ CALL STPLQT( 2, 2, 1, 2, A, 2, B, 2, T, 1, W, INFO )
+ CALL CHKXER( 'STPLQT', INFOT, NOUT, LERR, OK )
+*
+* STPLQT2
+*
+ SRNAMT = 'STPLQT2'
+ INFOT = 1
+ CALL STPLQT2( -1, 0, 0, A, 1, B, 1, T, 1, INFO )
+ CALL CHKXER( 'STPLQT2', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL STPLQT2( 0, -1, 0, A, 1, B, 1, T, 1, INFO )
+ CALL CHKXER( 'STPLQT2', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL STPLQT2( 0, 0, -1, A, 1, B, 1, T, 1, INFO )
+ CALL CHKXER( 'STPLQT2', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL STPLQT2( 2, 2, 0, A, 1, B, 2, T, 2, INFO )
+ CALL CHKXER( 'STPLQT2', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL STPLQT2( 2, 2, 0, A, 2, B, 1, T, 2, INFO )
+ CALL CHKXER( 'STPLQT2', INFOT, NOUT, LERR, OK )
+ INFOT = 9
+ CALL STPLQT2( 2, 2, 0, A, 2, B, 2, T, 1, INFO )
+ CALL CHKXER( 'STPLQT2', INFOT, NOUT, LERR, OK )
+*
+* STPMLQT
+*
+ SRNAMT = 'STPMLQT'
+ INFOT = 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,
+ $ 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,
+ $ 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,
+ $ 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,
+ $ W, INFO )
+ INFOT = 6
+ 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,
+ $ 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,
+ $ 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,
+ $ 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,
+ $ 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,
+ $ W, INFO )
+ CALL CHKXER( 'STPMLQT', INFOT, NOUT, LERR, OK )
+*
+* Print a summary line.
+*
+ CALL ALAESM( PATH, OK, NOUT )
+*
+ RETURN
+*
+* End of SERRLQT
+*
+ END
--- /dev/null
+*> \brief \b DERRTSQR
+*
+* =========== DOCUMENTATION ===========
+*
+* 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:
+* =============
+*>
+*> \verbatim
+*>
+*> DERRTSQR tests the error exits for the REAL routines
+*> that use the TSQR decomposition of a general matrix.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] PATH
+*> \verbatim
+*> PATH is CHARACTER*3
+*> The LAPACK path name for the routines to be tested.
+*> \endverbatim
+*>
+*> \param[in] NUNIT
+*> \verbatim
+*> NUNIT is INTEGER
+*> The unit number for output.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2011
+*
+*> \ingroup double_lin
+*
+* =====================================================================
+ SUBROUTINE SERRTSQR( PATH, NUNIT )
+ IMPLICIT NONE
+*
+* -- LAPACK test routine (version 3.4.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2011
+*
+* .. Scalar Arguments ..
+ CHARACTER*3 PATH
+ INTEGER NUNIT
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER NMAX
+ PARAMETER ( NMAX = 2 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, INFO, J, NB
+* ..
+* .. Local Arrays ..
+ REAL A( NMAX, NMAX ), T( NMAX, NMAX ), W( NMAX ),
+ $ C( NMAX, NMAX ), TAU(NMAX)
+* ..
+* .. External Subroutines ..
+ EXTERNAL ALAESM, CHKXER, SGEQR,
+ $ SGEMQR, SGELQ, SGEMLQ
+* ..
+* .. Scalars in Common ..
+ LOGICAL LERR, OK
+ CHARACTER*32 SRNAMT
+ INTEGER INFOT, NOUT
+* ..
+* .. Common blocks ..
+ COMMON / INFOC / INFOT, NOUT, OK, LERR
+ COMMON / SRNAMC / SRNAMT
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC REAL
+* ..
+* .. Executable Statements ..
+*
+ NOUT = NUNIT
+ WRITE( NOUT, FMT = * )
+*
+* Set the variables to innocuous values.
+*
+ DO J = 1, NMAX
+ DO I = 1, NMAX
+ A( I, J ) = 1.D0 / REAL( I+J )
+ C( I, J ) = 1.D0 / REAL( I+J )
+ T( I, J ) = 1.D0 / REAL( I+J )
+ END DO
+ W( J ) = 0.D0
+ END DO
+ OK = .TRUE.
+*
+* Error exits for TS factorization
+*
+* SGEQR
+*
+ SRNAMT = 'SGEQR'
+ INFOT = 1
+ CALL SGEQR( -1, 0, A, 1, TAU, 1, W, 1, INFO )
+ CALL CHKXER( 'SGEQR', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL SGEQR( 0, -1, A, 1, TAU, 1, W, 1, INFO )
+ CALL CHKXER( 'SGEQR', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL SGEQR( 1, 1, A, 0, TAU, 1, W, 1, INFO )
+ CALL CHKXER( 'SGEQR', INFOT, NOUT, LERR, OK )
+ INFOT = 6
+ CALL SGEQR( 3, 2, A, 3, TAU, 1, W, 1, INFO )
+ CALL CHKXER( 'SGEQR', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL SGEQR( 3, 2, A, 3, TAU, 7, W, 0, INFO )
+ CALL CHKXER( 'SGEQR', INFOT, NOUT, LERR, OK )
+*
+* SGEMQR
+*
+ TAU(1)=1
+ TAU(2)=1
+ SRNAMT = 'SGEMQR'
+ NB=1
+ INFOT = 1
+ CALL SGEMQR( '/', 'N', 0, 0, 0, A, 1, TAU, 1, C, 1, W, 1,INFO)
+ CALL CHKXER( 'SGEMQR', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL SGEMQR( 'L', '/', 0, 0, 0, A, 1, TAU, 1, C, 1, W, 1,INFO)
+ CALL CHKXER( 'SGEMQR', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL SGEMQR( 'L', 'N', -1, 0, 0, A, 1, TAU, 1, C, 1, W,1,INFO)
+ CALL CHKXER( 'SGEMQR', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL SGEMQR( 'L', 'N', 0, -1, 0, A, 1, TAU, 1, C, 1, W,1,INFO)
+ CALL CHKXER( 'SGEMQR', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL SGEMQR( 'L', 'N', 0, 0, -1, A, 1, TAU, 1, C, 1, W,1,INFO)
+ CALL CHKXER( 'SGEMQR', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL SGEMQR( 'R', 'N', 0, 0, -1, A, 1, TAU, 1, C, 1, W,1,INFO)
+ CALL CHKXER( 'SGEMQR', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL SGEMQR( 'L', 'N', 2, 1, 0, A, 0, TAU, 1, C, 1, W, 1,INFO)
+ CALL CHKXER( 'SGEMQR', INFOT, NOUT, LERR, OK )
+ INFOT = 9
+ CALL SGEMQR( 'R', 'N', 2, 2, 1, A, 1, TAU, 0, C, 1, W, 1,INFO)
+ CALL CHKXER( 'SGEMQR', INFOT, NOUT, LERR, OK )
+ INFOT = 9
+ CALL SGEMQR( 'L', 'N', 2, 2, 1, A, 1, TAU, 0, C, 1, W, 1,INFO)
+ CALL CHKXER( 'SGEMQR', INFOT, NOUT, LERR, OK )
+ INFOT = 11
+ CALL SGEMQR( 'L', 'N', 2, 1, 1, A, 1, TAU, 6, C, 0, W, 1,INFO)
+ CALL CHKXER( 'SGEMQR', INFOT, NOUT, LERR, OK )
+ INFOT = 13
+ CALL SGEMQR( 'L', 'N', 2, 2, 1, A, 2, TAU, 6, C, 2, W, 0,INFO)
+ CALL CHKXER( 'SGEMQR', INFOT, NOUT, LERR, OK )
+*
+* SGELQ
+*
+ SRNAMT = 'SGELQ'
+ INFOT = 1
+ CALL SGELQ( -1, 0, A, 1, TAU, 1, W, 1, INFO )
+ CALL CHKXER( 'SGELQ', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL SGELQ( 0, -1, A, 1, TAU, 1, W, 1, INFO )
+ CALL CHKXER( 'SGELQ', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL SGELQ( 1, 1, A, 0, TAU, 1, W, 1, INFO )
+ CALL CHKXER( 'SGELQ', INFOT, NOUT, LERR, OK )
+ INFOT = 6
+ CALL SGELQ( 2, 3, A, 3, TAU, 1, W, 1, INFO )
+ CALL CHKXER( 'SGELQ', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL SGELQ( 2, 3, A, 3, TAU, 7, W, 0, INFO )
+ CALL CHKXER( 'SGELQ', INFOT, NOUT, LERR, OK )
+*
+* SGEMLQ
+*
+ TAU(1)=1
+ TAU(2)=1
+ SRNAMT = 'SGEMLQ'
+ NB=1
+ INFOT = 1
+ CALL SGEMLQ( '/', 'N', 0, 0, 0, A, 1, TAU, 1, C, 1, W, 1,INFO)
+ CALL CHKXER( 'SGEMLQ', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL SGEMLQ( 'L', '/', 0, 0, 0, A, 1, TAU, 1, C, 1, W, 1,INFO)
+ CALL CHKXER( 'SGEMLQ', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL SGEMLQ( 'L', 'N', -1, 0, 0, A, 1, TAU, 1, C, 1, W,1,INFO)
+ CALL CHKXER( 'SGEMLQ', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL SGEMLQ( 'L', 'N', 0, -1, 0, A, 1, TAU, 1, C, 1, W,1,INFO)
+ CALL CHKXER( 'SGEMLQ', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL SGEMLQ( 'L', 'N', 0, 0, -1, A, 1, TAU, 1, C, 1, W,1,INFO)
+ CALL CHKXER( 'SGEMLQ', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL SGEMLQ( 'R', 'N', 0, 0, -1, A, 1, TAU, 1, C, 1, W,1,INFO)
+ CALL CHKXER( 'SGEMLQ', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL SGEMLQ( 'L', 'N', 1, 2, 0, A, 0, TAU, 1, C, 1, W, 1,INFO)
+ CALL CHKXER( 'SGEMLQ', INFOT, NOUT, LERR, OK )
+ INFOT = 9
+ CALL SGEMLQ( 'R', 'N', 2, 2, 1, A, 1, TAU, 0, C, 1, W, 1,INFO)
+ CALL CHKXER( 'SGEMLQ', INFOT, NOUT, LERR, OK )
+ INFOT = 9
+ CALL SGEMLQ( 'L', 'N', 2, 2, 1, A, 1, TAU, 0, C, 1, W, 1,INFO)
+ CALL CHKXER( 'SGEMLQ', INFOT, NOUT, LERR, OK )
+ INFOT = 11
+ CALL SGEMLQ( 'L', 'N', 1, 2, 1, A, 1, TAU, 6, C, 0, W, 1,INFO)
+ CALL CHKXER( 'SGEMLQ', INFOT, NOUT, LERR, OK )
+ INFOT = 13
+ CALL SGEMLQ( 'L', 'N', 2, 2, 1, A, 2, TAU, 6, C, 2, W, 0,INFO)
+ CALL CHKXER( 'SGEMLQ', INFOT, NOUT, LERR, OK )
+*
+* Print a summary line.
+*
+ CALL ALAESM( PATH, OK, NOUT )
+*
+ RETURN
+*
+* End of SERRTSQR
+*
+ END
--- /dev/null
+*> \brief \b SLQT04
+*
+* =========== DOCUMENTATION ===========
+*
+* 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:
+* =============
+*>
+*> \verbatim
+*>
+*> SLQT04 tests SGELQT and SGEMLQT.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> Number of rows in test matrix.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> Number of columns in test matrix.
+*> \endverbatim
+*>
+*> \param[in] NB
+*> \verbatim
+*> NB is INTEGER
+*> Block size of test matrix. NB <= Min(M,N).
+*> \endverbatim
+*>
+*> \param[out] RESULT
+*> \verbatim
+*> RESULT is REAL array, dimension (6)
+*> Results of each of the six tests below.
+*>
+*> RESULT(1) = | A - L Q |
+*> 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(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.
+*
+*> \date April 2012
+*
+*> \ingroup double_lin
+*
+* =====================================================================
+ SUBROUTINE SLQT04(M,N,NB,RESULT)
+ IMPLICIT NONE
+*
+* -- LAPACK test routine (version 3.4.1) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* April 2012
+*
+* .. Scalar Arguments ..
+ INTEGER M, N, NB, LDT
+* .. Return values ..
+ REAL RESULT(6)
+*
+* =====================================================================
+*
+* ..
+* .. Local allocatable arrays
+ REAL, ALLOCATABLE :: AF(:,:), Q(:,:),
+ $ L(:,:), RWORK(:), WORK( : ), T(:,:),
+ $ CF(:,:), DF(:,:), A(:,:), C(:,:), D(:,:)
+*
+* .. Parameters ..
+ REAL ONE, ZERO
+ PARAMETER( ZERO = 0.0, ONE = 1.0 )
+* ..
+* .. Local Scalars ..
+ INTEGER INFO, J, K, LL, LWORK
+ REAL ANORM, EPS, RESID, CNORM, DNORM
+* ..
+* .. Local Arrays ..
+ INTEGER ISEED( 4 )
+* ..
+* .. External Functions ..
+ REAL SLAMCH, SLANGE, SLANSY
+ LOGICAL LSAME
+ EXTERNAL SLAMCH, SLANGE, SLANSY, LSAME
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Data statements ..
+ DATA ISEED / 1988, 1989, 1990, 1991 /
+*
+ EPS = SLAMCH( 'Epsilon' )
+ K = MIN(M,N)
+ LL = MAX(M,N)
+ LWORK = MAX(2,LL)*MAX(2,LL)*NB
+*
+* 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),
+ $ D(N,M), DF(N,M) )
+*
+* Put random numbers into A and copy to AF
+*
+ LDT=NB
+ DO J=1,N
+ CALL SLARNV( 2, ISEED, M, A( 1, J ) )
+ END DO
+ CALL SLACPY( 'Full', M, N, A, M, AF, M )
+*
+* Factor the matrix A in the array AF.
+*
+ CALL SGELQT( M, N, NB, AF, M, T, LDT, WORK, INFO )
+*
+* 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,
+ $ WORK, INFO )
+*
+* Copy R
+*
+ CALL SLASET( 'Full', M, N, ZERO, ZERO, L, LL )
+ CALL SLACPY( 'Lower', M, N, AF, M, L, LL )
+*
+* Compute |L - A*Q'| / |A| and store in RESULT(1)
+*
+ CALL SGEMM( 'N', 'T', M, N, N, -ONE, A, M, Q, N, ONE, L, LL )
+ ANORM = SLANGE( '1', M, N, A, M, RWORK )
+ RESID = SLANGE( '1', M, N, L, LL, RWORK )
+ IF( ANORM.GT.ZERO ) THEN
+ RESULT( 1 ) = RESID / (EPS*MAX(1,M)*ANORM)
+ ELSE
+ RESULT( 1 ) = ZERO
+ END IF
+*
+* Compute |I - Q'*Q| and store in RESULT(2)
+*
+ CALL SLASET( 'Full', N, N, ZERO, ONE, L, LL )
+ CALL SSYRK( 'U', 'C', N, N, -ONE, Q, N, ONE, L, LL )
+ RESID = SLANSY( '1', 'Upper', N, L, LL, RWORK )
+ RESULT( 2 ) = RESID / (EPS*MAX(1,N))
+*
+* Generate random m-by-n matrix C and a copy CF
+*
+ DO J=1,M
+ CALL SLARNV( 2, ISEED, N, D( 1, J ) )
+ END DO
+ DNORM = SLANGE( '1', N, M, D, N, RWORK)
+ CALL SLACPY( 'Full', N, M, D, N, DF, N )
+*
+* Apply Q to C as Q*C
+*
+ CALL SGEMLQT( 'L', 'N', N, M, K, NB, AF, M, T, NB, DF, N,
+ $ WORK, INFO)
+*
+* Compute |Q*D - Q*D| / |D|
+*
+ CALL SGEMM( 'N', 'N', N, M, N, -ONE, Q, N, D, N, ONE, DF, N )
+ RESID = SLANGE( '1', N, M, DF, N, RWORK )
+ IF( DNORM.GT.ZERO ) THEN
+ RESULT( 3 ) = RESID / (EPS*MAX(1,M)*DNORM)
+ ELSE
+ RESULT( 3 ) = ZERO
+ END IF
+*
+* Copy D into DF again
+*
+ CALL SLACPY( 'Full', N, M, D, N, DF, N )
+*
+* Apply Q to D as QT*D
+*
+ CALL SGEMLQT( 'L', 'T', N, M, K, NB, AF, M, T, NB, DF, N,
+ $ WORK, INFO)
+*
+* Compute |QT*D - QT*D| / |D|
+*
+ CALL SGEMM( 'T', 'N', N, M, N, -ONE, Q, N, D, N, ONE, DF, N )
+ RESID = SLANGE( '1', N, M, DF, N, RWORK )
+ IF( DNORM.GT.ZERO ) THEN
+ RESULT( 4 ) = RESID / (EPS*MAX(1,M)*DNORM)
+ ELSE
+ RESULT( 4 ) = ZERO
+ END IF
+*
+* Generate random n-by-m matrix D and a copy DF
+*
+ DO J=1,N
+ CALL SLARNV( 2, ISEED, M, C( 1, J ) )
+ END DO
+ CNORM = SLANGE( '1', M, N, C, M, RWORK)
+ CALL SLACPY( 'Full', M, N, C, M, CF, M )
+*
+* Apply Q to C as C*Q
+*
+ CALL SGEMLQT( 'R', 'N', M, N, K, NB, AF, M, T, NB, CF, M,
+ $ WORK, INFO)
+*
+* Compute |C*Q - C*Q| / |C|
+*
+ CALL SGEMM( 'N', 'N', M, N, N, -ONE, C, M, Q, N, ONE, CF, M )
+ RESID = SLANGE( '1', N, M, DF, N, RWORK )
+ IF( CNORM.GT.ZERO ) THEN
+ RESULT( 5 ) = RESID / (EPS*MAX(1,M)*DNORM)
+ ELSE
+ RESULT( 5 ) = ZERO
+ END IF
+*
+* Copy C into CF again
+*
+ CALL SLACPY( 'Full', M, N, C, M, CF, M )
+*
+* Apply Q to D as D*QT
+*
+ CALL SGEMLQT( 'R', 'T', M, N, K, NB, AF, M, T, NB, CF, M,
+ $ WORK, INFO)
+*
+* Compute |C*QT - C*QT| / |C|
+*
+ CALL SGEMM( 'N', 'T', M, N, N, -ONE, C, M, Q, N, ONE, CF, M )
+ RESID = SLANGE( '1', M, N, CF, M, RWORK )
+ IF( CNORM.GT.ZERO ) THEN
+ RESULT( 6 ) = RESID / (EPS*MAX(1,M)*DNORM)
+ ELSE
+ RESULT( 6 ) = ZERO
+ END IF
+*
+* Deallocate all arrays
+*
+ DEALLOCATE ( A, AF, Q, L, RWORK, WORK, T, C, D, CF, DF)
+*
+ RETURN
+ END
+
--- /dev/null
+* Definition:
+* ===========
+*
+* SUBROUTINE SLQT05(M,N,L,NB,RESULT)
+*
+* .. Scalar Arguments ..
+* INTEGER LWORK, M, N, L, NB, LDT
+* .. Return values ..
+* REAL RESULT(6)
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> SQRT05 tests STPLQT and STPMLQT.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> Number of rows in lower part of the test matrix.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> Number of columns in test matrix.
+*> \endverbatim
+*>
+*> \param[in] L
+*> \verbatim
+*> L is INTEGER
+*> The number of rows of the upper trapezoidal part the
+*> lower test matrix. 0 <= L <= M.
+*> \endverbatim
+*>
+*> \param[in] NB
+*> \verbatim
+*> NB is INTEGER
+*> Block size of test matrix. NB <= N.
+*> \endverbatim
+*>
+*> \param[out] RESULT
+*> \verbatim
+*> RESULT is REAL array, dimension (6)
+*> Results of each of the six tests below.
+*>
+*> RESULT(1) = | A - Q R |
+*> 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(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.
+*
+*> \date April 2012
+*
+*> \ingroup double_lin
+*
+* =====================================================================
+ SUBROUTINE SLQT05(M,N,L,NB,RESULT)
+ IMPLICIT NONE
+*
+* -- LAPACK test routine (version 3.4.1) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* April 2012
+*
+* .. Scalar Arguments ..
+ INTEGER LWORK, M, N, L, NB, LDT
+* .. Return values ..
+ REAL RESULT(6)
+*
+* =====================================================================
+*
+* ..
+* .. Local allocatable arrays
+ REAL, ALLOCATABLE :: AF(:,:), Q(:,:),
+ $ R(:,:), RWORK(:), WORK( : ), T(:,:),
+ $ CF(:,:), DF(:,:), A(:,:), C(:,:), D(:,:)
+*
+* .. Parameters ..
+ REAL ONE, ZERO
+ PARAMETER( ZERO = 0.0, ONE = 1.0 )
+* ..
+* .. Local Scalars ..
+ INTEGER INFO, J, K, N2, NP1,i
+ REAL ANORM, EPS, RESID, CNORM, DNORM
+* ..
+* .. Local Arrays ..
+ INTEGER ISEED( 4 )
+* ..
+* .. External Functions ..
+ REAL SLAMCH, SLANGE, SLANSY
+ LOGICAL LSAME
+ EXTERNAL SLAMCH, SLANGE, SLANSY, LSAME
+* ..
+* .. Data statements ..
+ DATA ISEED / 1988, 1989, 1990, 1991 /
+*
+ EPS = SLAMCH( 'Epsilon' )
+ K = M
+ N2 = M+N
+ IF( N.GT.0 ) THEN
+ NP1 = M+1
+ ELSE
+ NP1 = 1
+ END IF
+ LWORK = N2*N2*NB
+*
+* 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),
+ $ D(M,N2),DF(M,N2) )
+*
+* Put random stuff into A
+*
+ LDT=NB
+ CALL SLASET( 'Full', M, N2, ZERO, ZERO, A, M )
+ CALL SLASET( 'Full', NB, M, ZERO, ZERO, T, NB )
+ DO J=1,M
+ CALL SLARNV( 2, ISEED, M-J+1, A( J, J ) )
+ END DO
+ IF( N.GT.0 ) THEN
+ DO J=1,N-L
+ CALL SLARNV( 2, ISEED, M, A( 1, MIN(N+M,M+1) + J - 1 ) )
+ END DO
+ 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)
+ $ + J - 1 ) )
+ END DO
+ END IF
+*
+* Copy the matrix A to the array AF.
+*
+ CALL SLACPY( 'Full', M, N2, A, M, AF, M )
+*
+* Factor the matrix A in the array AF.
+*
+ CALL STPLQT( M,N,L,NB,AF,M,AF(1,NP1),M,T,LDT,WORK,INFO)
+*
+* Generate the (M+N)-by-(M+N) matrix Q by applying H to I
+*
+ CALL SLASET( 'Full', N2, N2, ZERO, ONE, Q, N2 )
+ CALL SGEMLQT( 'L', 'N', N2, N2, K, NB, AF, M, T, LDT, Q, N2,
+ $ WORK, INFO )
+*
+* Copy L
+*
+ CALL SLASET( 'Full', N2, N2, ZERO, ZERO, R, N2 )
+ CALL SLACPY( 'Lower', M, N2, AF, M, R, N2 )
+*
+* Compute |L - A*Q*T| / |A| and store in RESULT(1)
+*
+ CALL SGEMM( 'N', 'T', M, N2, N2, -ONE, A, M, Q, N2, ONE, R, N2)
+ ANORM = SLANGE( '1', M, N2, A, M, RWORK )
+ RESID = SLANGE( '1', M, N2, R, N2, RWORK )
+ IF( ANORM.GT.ZERO ) THEN
+ RESULT( 1 ) = RESID / (EPS*ANORM*MAX(1,N2))
+ ELSE
+ RESULT( 1 ) = ZERO
+ END IF
+*
+* Compute |I - Q*Q'| and store in RESULT(2)
+*
+ CALL SLASET( 'Full', N2, N2, ZERO, ONE, R, N2 )
+ CALL SSYRK( 'U', 'N', N2, N2, -ONE, Q, N2, ONE, R, N2 )
+ RESID = SLANSY( '1', 'Upper', N2, R, N2, RWORK )
+ RESULT( 2 ) = RESID / (EPS*MAX(1,N2))
+*
+* Generate random m-by-n matrix C and a copy CF
+*
+ CALL SLASET( 'Full', N2, M, ZERO, ONE, C, N2 )
+ DO J=1,M
+ CALL SLARNV( 2, ISEED, N2, C( 1, J ) )
+ END DO
+ CNORM = SLANGE( '1', N2, M, C, N2, RWORK)
+ 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)
+*
+* Compute |Q*C - Q*C| / |C|
+*
+ CALL SGEMM( 'N', '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( 3 ) = RESID / (EPS*MAX(1,N2)*CNORM)
+ ELSE
+ RESULT( 3 ) = ZERO
+ END IF
+
+*
+* Copy C into CF again
+*
+ CALL SLACPY( 'Full', N2, M, C, N2, CF, N2 )
+*
+* 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)
+*
+* 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
+*
+* Generate random m-by-n matrix D and a copy DF
+*
+ DO J=1,N2
+ CALL SLARNV( 2, ISEED, M, D( 1, J ) )
+ END DO
+ DNORM = SLANGE( '1', M, N2, D, M, RWORK)
+ CALL SLACPY( 'Full', M, N2, D, M, DF, M )
+*
+* Apply Q to D as D*Q
+*
+ CALL STPMLQT('R','N',M,N,K,L,NB,AF(1,NP1),M,T,LDT,DF,M,
+ $ DF(1,NP1),M,WORK,INFO)
+*
+* Compute |D*Q - D*Q| / |D|
+*
+ CALL SGEMM('N','N',M,N2,N2,-ONE,D,M,Q,N2,ONE,DF,M)
+ RESID = SLANGE('1',M, N2,DF,M,RWORK )
+ IF( CNORM.GT.ZERO ) THEN
+ RESULT( 5 ) = RESID / (EPS*MAX(1,N2)*DNORM)
+ ELSE
+ RESULT( 5 ) = ZERO
+ END IF
+*
+* Copy D into DF again
+*
+ CALL SLACPY('Full',M,N2,D,M,DF,M )
+*
+* 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)
+
+*
+* Compute |D*QT - D*QT| / |D|
+*
+ CALL SGEMM( 'N', 'T', M, N2, N2, -ONE, D, M, Q, N2, ONE, DF, M )
+ RESID = SLANGE( '1', M, N2, DF, M, RWORK )
+ IF( CNORM.GT.ZERO ) THEN
+ RESULT( 6 ) = RESID / (EPS*MAX(1,N2)*DNORM)
+ ELSE
+ RESULT( 6 ) = ZERO
+ END IF
+*
+* Deallocate all arrays
+*
+ DEALLOCATE ( A, AF, Q, R, RWORK, WORK, T, C, D, CF, DF)
+ RETURN
+ END
\ No newline at end of file
--- /dev/null
+* 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
+*>
+*> 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
+*
+* Arguments:
+* ==========
+*
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows of the matrix B, and the order of the
+*> triangular matrix A.
+*> M >= 0.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of columns of the matrix B.
+*> N >= 0.
+*> \endverbatim
+*>
+*> \param[in] L
+*> \verbatim
+*> L is INTEGER
+*> The number of rows of the lower trapezoidal part of B.
+*> MIN(M,N) >= L >= 0. See Further Details.
+*> \endverbatim
+*>
+*> \param[in] MB
+*> \verbatim
+*> MB is INTEGER
+*> The block size to be used in the blocked QR. M >= MB >= 1.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is REAL array, dimension (LDA,N)
+*> On entry, the lower triangular N-by-N matrix A.
+*> On exit, the elements on and below the diagonal of the array
+*> contain the lower triangular matrix L.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in,out] B
+*> \verbatim
+*> B is REAL array, dimension (LDB,N)
+*> 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
+*>
+*> \param[in] LDB
+*> \verbatim
+*> LDB is INTEGER
+*> The leading dimension of the array B. LDB >= max(1,M).
+*> \endverbatim
+*>
+*> \param[out] T
+*> \verbatim
+*> T is REAL array, dimension (LDT,N)
+*> 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
+*> The leading dimension of the array T. LDT >= MB.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is REAL array, dimension (MB*M)
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> < 0: if INFO = -i, the i-th argument had an illegal value
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2013
+*
+*> \ingroup doubleOTHERcomputational
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*>
+*> 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 ]
+*> [ 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.
+*>
+*> 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 ]
+*> [ A ] <- lower triangular N-by-N
+*> [ B ] <- M-by-N pentagonal
+*>
+*> so that W can be represented as
+*> [ 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 ]
+*> [ 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 number of blocks is B = ceiling(M/MB), where each
+*> 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
+*> for the last block) T's are stored in the MB-by-N matrix T as
+*>
+*> T = [T1 T2 ... TB].
+*> \endverbatim
+*>
+* =====================================================================
+ SUBROUTINE STPLQT( M, N, L, MB, A, LDA, B, LDB, T, LDT, WORK,
+ $ INFO )
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2013
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, LDB, LDT, N, M, L, MB
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * ), B( LDB, * ), T( LDT, * ), WORK( * )
+* ..
+*
+* =====================================================================
+*
+* ..
+* .. Local Scalars ..
+ INTEGER I, IB, LB, NB, IINFO
+* ..
+* .. External Subroutines ..
+ EXTERNAL STPLQT2, STPRFB, XERBLA
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+ IF( M.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( L.LT.0 .OR. (L.GT.MIN(M,N) .AND. MIN(M,N).GE.0)) THEN
+ INFO = -3
+ ELSE IF( MB.LT.1 .OR. (MB.GT.M .AND. M.GT.0)) THEN
+ INFO = -4
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -6
+ ELSE IF( LDB.LT.MAX( 1, M ) ) THEN
+ INFO = -8
+ ELSE IF( LDT.LT.MB ) THEN
+ INFO = -10
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'STPLQT', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ 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 )
+ NB = MIN( N-L+I+IB-1, N )
+ IF( I.GE.L ) THEN
+ LB = 0
+ ELSE
+ LB = NB-N+L-I+1
+ END IF
+*
+ 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,
+ $ WORK, M-I-IB+1)
+ END IF
+ END DO
+ RETURN
+*
+* End of STPLQT
+*
+ END
--- /dev/null
+*> \brief \b STSQR01
+*
+* =========== DOCUMENTATION ===========
+*
+* 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:
+* =============
+*>
+*> \verbatim
+*>
+*> DTSQR01 tests DGEQR , DGELQ, DGEMLQ and DGEMQR.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] TSSW
+*> \verbatim
+*> TSSW is CHARACTER
+*> 'TS' for testing tall skinny QR
+*> and anything else for testing short wide LQ
+*> \endverbatim
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> Number of rows in test matrix.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> Number of columns in test matrix.
+*> \endverbatim
+*> \param[in] MB
+*> \verbatim
+*> MB is INTEGER
+*> Number of row in row block in test matrix.
+*> \endverbatim
+*>
+*> \param[in] NB
+*> \verbatim
+*> NB is INTEGER
+*> Number of columns in column block test matrix.
+*> \endverbatim
+*>
+*> \param[out] RESULT
+*> \verbatim
+*> RESULT is REAL array, dimension (6)
+*> Results of each of the six tests below.
+*>
+*> RESULT(1) = | A - Q R | or | A - L Q |
+*> 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(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.
+*
+*> \date April 2012
+*
+*> \ingroup double_lin
+*
+* =====================================================================
+ SUBROUTINE STSQR01(TSSW, M, N, MB, NB, RESULT)
+ IMPLICIT NONE
+*
+* -- LAPACK test routine (version 3.4.1) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* April 2012
+*
+* .. Scalar Arguments ..
+ CHARACTER TSSW
+ INTEGER M, N, MB, NB
+* .. Return values ..
+ REAL RESULT(6)
+*
+* =====================================================================
+*
+* ..
+* .. Local allocatable arrays
+ REAL, ALLOCATABLE :: AF(:,:), Q(:,:),
+ $ R(:,:), RWORK(:), WORK( : ), T(:),
+ $ CF(:,:), DF(:,:), A(:,:), C(:,:), D(:,:), LQ(:,:)
+*
+* .. Parameters ..
+ REAL ONE, ZERO
+ PARAMETER( ZERO = 0.0, ONE = 1.0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL TESTZEROS, TS
+ INTEGER INFO, J, K, L, LWORK, LT ,MNB
+ REAL ANORM, EPS, RESID, CNORM, DNORM
+* ..
+* .. Local Arrays ..
+ INTEGER ISEED( 4 )
+* ..
+* .. External Functions ..
+ REAL SLAMCH, SLANGE, SLANSY
+ LOGICAL LSAME
+ INTEGER ILAENV
+ EXTERNAL SLAMCH, SLARNV, SLANGE, SLANSY, LSAME, ILAENV
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* .. Scalars in Common ..
+ CHARACTER*32 srnamt
+* ..
+* .. Common blocks ..
+ COMMON / srnamc / srnamt
+* ..
+* .. Data statements ..
+ 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 = SLAMCH( 'Epsilon' )
+ K = MIN(M,N)
+ L = MAX(M,N,1)
+ MNB = MAX ( MB, NB)
+ LWORK = MAX(3,L)*MNB
+ 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
+ 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),
+ $ D(N,M), DF(N,M), LQ(L,N) )
+*
+* Put random numbers into A and copy to AF
+*
+ DO J=1,N
+ CALL SLARNV( 2, ISEED, M, A( 1, J ) )
+ END DO
+ IF (TESTZEROS) THEN
+ IF (M.GE.4) THEN
+ DO J=1,N
+ CALL SLARNV( 2, ISEED, M/2, A( M/4, J ) )
+ END DO
+ END IF
+ END IF
+ CALL SLACPY( 'Full', M, N, A, M, AF, M )
+*
+ IF (TS) THEN
+*
+* Factor the matrix A in the array AF.
+*
+ srnamt = 'SGEQR'
+ CALL SGEQR( M, N, AF, M, T, LT, WORK, LWORK, INFO )
+*
+* Generate the m-by-m matrix Q
+*
+ CALL SLASET( 'Full', M, M, ZERO, ONE, Q, M )
+ srnamt = 'SGEMQR'
+ CALL SGEMQR( 'L', 'N', M, M, K, AF, M, T, LT, Q, M,
+ $ WORK, LWORK, INFO )
+*
+* Copy R
+*
+ CALL SLASET( 'Full', M, N, ZERO, ZERO, R, M )
+ CALL SLACPY( 'Upper', M, N, AF, M, R, M )
+*
+* Compute |R - Q'*A| / |A| and store in RESULT(1)
+*
+ CALL SGEMM( 'T', 'N', M, N, M, -ONE, Q, M, A, M, ONE, R, M )
+ ANORM = SLANGE( '1', M, N, A, M, RWORK )
+ RESID = SLANGE( '1', M, N, R, M, RWORK )
+ IF( ANORM.GT.ZERO ) THEN
+ RESULT( 1 ) = RESID / (EPS*MAX(1,M)*ANORM)
+ ELSE
+ RESULT( 1 ) = ZERO
+ END IF
+*
+* Compute |I - Q'*Q| and store in RESULT(2)
+*
+ CALL SLASET( 'Full', M, M, ZERO, ONE, R, M )
+ CALL SSYRK( 'U', 'C', M, M, -ONE, Q, M, ONE, R, M )
+ RESID = SLANSY( '1', 'Upper', M, R, M, RWORK )
+ RESULT( 2 ) = RESID / (EPS*MAX(1,M))
+*
+* Generate random m-by-n matrix C and a copy CF
+*
+ DO J=1,N
+ CALL SLARNV( 2, ISEED, M, C( 1, J ) )
+ END DO
+ CNORM = SLANGE( '1', M, N, C, M, RWORK)
+ CALL SLACPY( 'Full', M, N, C, M, CF, M )
+*
+* Apply Q to C as Q*C
+*
+ srnamt = 'DGEQR'
+ CALL SGEMQR( 'L', 'N', M, N, K, AF, M, T, LT, CF, M,
+ $ WORK, LWORK, INFO)
+*
+* Compute |Q*C - Q*C| / |C|
+*
+ CALL SGEMM( 'N', 'N', M, N, M, -ONE, Q, M, C, M, ONE, CF, M )
+ RESID = SLANGE( '1', M, N, CF, M, RWORK )
+ IF( CNORM.GT.ZERO ) THEN
+ RESULT( 3 ) = RESID / (EPS*MAX(1,M)*CNORM)
+ ELSE
+ RESULT( 3 ) = ZERO
+ END IF
+*
+* Copy C into CF again
+*
+ CALL SLACPY( 'Full', M, N, C, M, CF, M )
+*
+* Apply Q to C as QT*C
+*
+ srnamt = 'DGEQR'
+ CALL SGEMQR( 'L', 'T', M, N, K, AF, M, T, LT, CF, M,
+ $ WORK, LWORK, INFO)
+*
+* Compute |QT*C - QT*C| / |C|
+*
+ CALL SGEMM( 'T', 'N', M, N, M, -ONE, Q, M, C, M, ONE, CF, M )
+ RESID = SLANGE( '1', M, N, CF, M, RWORK )
+ IF( CNORM.GT.ZERO ) THEN
+ RESULT( 4 ) = RESID / (EPS*MAX(1,M)*CNORM)
+ ELSE
+ RESULT( 4 ) = ZERO
+ END IF
+*
+* Generate random n-by-m matrix D and a copy DF
+*
+ DO J=1,M
+ CALL SLARNV( 2, ISEED, N, D( 1, J ) )
+ END DO
+ DNORM = SLANGE( '1', N, M, D, N, RWORK)
+ CALL SLACPY( 'Full', N, M, D, N, DF, N )
+*
+* 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)
+*
+* Compute |D*Q - D*Q| / |D|
+*
+ CALL SGEMM( 'N', 'N', N, M, M, -ONE, D, N, Q, M, ONE, DF, N )
+ RESID = SLANGE( '1', N, M, DF, N, RWORK )
+ IF( DNORM.GT.ZERO ) THEN
+ RESULT( 5 ) = RESID / (EPS*MAX(1,M)*DNORM)
+ ELSE
+ RESULT( 5 ) = ZERO
+ END IF
+*
+* Copy D into DF again
+*
+ CALL SLACPY( 'Full', N, M, D, N, DF, N )
+*
+* Apply Q to D as D*QT
+*
+ CALL SGEMQR( 'R', 'T', N, M, K, AF, M, T, LT, DF, N,
+ $ WORK, LWORK, INFO)
+*
+* Compute |D*QT - D*QT| / |D|
+*
+ CALL SGEMM( 'N', 'T', N, M, M, -ONE, D, N, Q, M, ONE, DF, N )
+ RESID = SLANGE( '1', N, M, DF, N, RWORK )
+ IF( CNORM.GT.ZERO ) THEN
+ RESULT( 6 ) = RESID / (EPS*MAX(1,M)*DNORM)
+ ELSE
+ RESULT( 6 ) = ZERO
+ END IF
+*
+* Short and wide
+*
+ ELSE
+ srnamt = 'SGELQ'
+ CALL SGELQ( M, N, AF, M, T, LT, WORK, LWORK, INFO )
+*
+*
+* Generate the n-by-n matrix Q
+*
+ CALL SLASET( 'Full', N, N, ZERO, ONE, Q, N )
+ srnamt = 'SGEMQR'
+ CALL SGEMLQ( 'R', 'N', N, N, K, AF, M, T, LT, Q, N,
+ $ WORK, LWORK, INFO )
+*
+* Copy R
+*
+ CALL SLASET( 'Full', M, N, ZERO, ZERO, LQ, L )
+ CALL SLACPY( 'Lower', M, N, AF, M, LQ, L )
+*
+* Compute |L - A*Q'| / |A| and store in RESULT(1)
+*
+ CALL SGEMM( 'N', 'T', M, N, N, -ONE, A, M, Q, N, ONE, LQ, L )
+ ANORM = SLANGE( '1', M, N, A, M, RWORK )
+ RESID = SLANGE( '1', M, N, LQ, L, RWORK )
+ IF( ANORM.GT.ZERO ) THEN
+ RESULT( 1 ) = RESID / (EPS*MAX(1,N)*ANORM)
+ ELSE
+ RESULT( 1 ) = ZERO
+ END IF
+*
+* Compute |I - Q'*Q| and store in RESULT(2)
+*
+ CALL SLASET( 'Full', N, N, ZERO, ONE, LQ, L )
+ CALL SSYRK( 'U', 'C', N, N, -ONE, Q, N, ONE, LQ, L )
+ RESID = SLANSY( '1', 'Upper', N, LQ, L, RWORK )
+ RESULT( 2 ) = RESID / (EPS*MAX(1,N))
+*
+* Generate random m-by-n matrix C and a copy CF
+*
+ DO J=1,M
+ CALL SLARNV( 2, ISEED, N, D( 1, J ) )
+ END DO
+ DNORM = SLANGE( '1', N, M, D, N, RWORK)
+ CALL SLACPY( 'Full', N, M, D, N, DF, N )
+*
+* Apply Q to C as Q*C
+*
+ CALL SGEMLQ( 'L', 'N', N, M, K, AF, M, T, LT, DF, N,
+ $ WORK, LWORK, INFO)
+*
+* Compute |Q*D - Q*D| / |D|
+*
+ CALL SGEMM( 'N', 'N', N, M, N, -ONE, Q, N, D, N, ONE, DF, N )
+ RESID = SLANGE( '1', N, M, DF, N, RWORK )
+ IF( DNORM.GT.ZERO ) THEN
+ RESULT( 3 ) = RESID / (EPS*MAX(1,N)*DNORM)
+ ELSE
+ RESULT( 3 ) = ZERO
+ END IF
+*
+* Copy D into DF again
+*
+ CALL SLACPY( 'Full', N, M, D, N, DF, N )
+*
+* Apply Q to D as QT*D
+*
+ CALL SGEMLQ( 'L', 'T', N, M, K, AF, M, T, LT, DF, N,
+ $ WORK, LWORK, INFO)
+*
+* Compute |QT*D - QT*D| / |D|
+*
+ CALL SGEMM( 'T', 'N', N, M, N, -ONE, Q, N, D, N, ONE, DF, N )
+ RESID = SLANGE( '1', N, M, DF, N, RWORK )
+ IF( DNORM.GT.ZERO ) THEN
+ RESULT( 4 ) = RESID / (EPS*MAX(1,N)*DNORM)
+ ELSE
+ RESULT( 4 ) = ZERO
+ END IF
+*
+* Generate random n-by-m matrix D and a copy DF
+*
+ DO J=1,N
+ CALL SLARNV( 2, ISEED, M, C( 1, J ) )
+ END DO
+ CNORM = SLANGE( '1', M, N, C, M, RWORK)
+ CALL SLACPY( 'Full', M, N, C, M, CF, M )
+*
+* Apply Q to C as C*Q
+*
+ CALL SGEMLQ( 'R', 'N', M, N, K, AF, M, T, LT, CF, M,
+ $ WORK, LWORK, INFO)
+*
+* Compute |C*Q - C*Q| / |C|
+*
+ CALL SGEMM( 'N', 'N', M, N, N, -ONE, C, M, Q, N, ONE, CF, M )
+ RESID = SLANGE( '1', N, M, DF, N, RWORK )
+ IF( CNORM.GT.ZERO ) THEN
+ RESULT( 5 ) = RESID / (EPS*MAX(1,N)*CNORM)
+ ELSE
+ RESULT( 5 ) = ZERO
+ END IF
+*
+* Copy C into CF again
+*
+ CALL SLACPY( 'Full', M, N, C, M, CF, M )
+*
+* Apply Q to D as D*QT
+*
+ CALL SGEMLQ( 'R', 'T', M, N, K, AF, M, T, LT, CF, M,
+ $ WORK, LWORK, INFO)
+*
+* Compute |C*QT - C*QT| / |C|
+*
+ CALL SGEMM( 'N', 'T', M, N, N, -ONE, C, M, Q, N, ONE, CF, M )
+ RESID = SLANGE( '1', M, N, CF, M, RWORK )
+ IF( CNORM.GT.ZERO ) THEN
+ RESULT( 6 ) = RESID / (EPS*MAX(1,N)*CNORM)
+ ELSE
+ RESULT( 6 ) = ZERO
+ END IF
+*
+ END IF
+*
+* Deallocate all arrays
+*
+ DEALLOCATE ( A, AF, Q, R, RWORK, WORK, T, C, D, CF, DF)
+*
+ RETURN
+ END
\ No newline at end of file
*
* =========== 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:
* ===========
*
* PROGRAM ZCHKAA
-*
+*
*
*> \par Purpose:
* =============
*> ZPB 8 List types on next line if 0 < NTYPES < 8
*> ZPT 12 List types on next line if 0 < NTYPES < 12
*> ZHE 10 List types on next line if 0 < NTYPES < 10
-*> ZHA 10 List types on next line if 0 < NTYPES < 10
*> ZHR 10 List types on next line if 0 < NTYPES < 10
*> ZHP 10 List types on next line if 0 < NTYPES < 10
*> ZSY 11 List types on next line if 0 < NTYPES < 11
*> ZEQ
*> ZQT
*> ZQX
+*> ZTQ
+*> ZXQ
+*> ZTS
*> \endverbatim
*
* Parameters:
* 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
+*> \date November 2015
*
*> \ingroup complex16_lin
*
* =====================================================================
PROGRAM ZCHKAA
*
-* -- LAPACK test routine (version 3.7.0) --
+* -- LAPACK test routine (version 3.6.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* November 2016
+* November 2015
*
* =====================================================================
*
$ ZCHKTB, ZCHKTP, ZCHKTR, ZCHKTZ, ZDRVGB, ZDRVGE,
$ ZDRVGT, ZDRVHE, ZDRVHE_ROOK, ZDRVHP, ZDRVLS,
$ ZDRVPB, ZDRVPO, ZDRVPP, ZDRVPT, ZDRVSP, ZDRVSY,
- $ ZDRVSY_ROOK, ILAVER, ZCHKQRT, ZCHKQRTP
+ $ ZDRVSY_ROOK, ILAVER, ZCHKQRT, ZCHKQRTP,
+ $ ZCHKLQT, ZCHKLQTP, ZCHKTSQR
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
WRITE( NOUT, FMT = 9988 )PATH
END IF
*
- ELSE IF( LSAMEN( 2, C2, 'HA' ) ) THEN
-*
-* HA: Hermitian indefinite matrices,
-* with partial (Aasen's) pivoting algorithm
-*
- NTYPES = 10
- CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
-*
- IF( TSTCHK ) THEN
- CALL ZCHKHE_AASEN( DOTYPE, NN, NVAL, NNB2, NBVAL2, NNS,
- $ 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 )
- ELSE
- WRITE( NOUT, FMT = 9989 )PATH
- END IF
-*
- 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 ),
- $ WORK, RWORK, IWORK, NOUT )
- ELSE
- WRITE( NOUT, FMT = 9988 )PATH
- END IF
-*
ELSE IF( LSAMEN( 2, C2, 'HR' ) ) THEN
*
* HR: Hermitian indefinite matrices,
* QT: QRT routines for general matrices
*
IF( TSTCHK ) THEN
- CALL ZCHKQRT( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
+ CALL ZCHKQRT( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
$ NBVAL, NOUT )
ELSE
WRITE( NOUT, FMT = 9989 )PATH
* QX: QRT routines for triangular-pentagonal matrices
*
IF( TSTCHK ) THEN
- CALL ZCHKQRTP( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
+ CALL ZCHKQRTP( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
+ $ NBVAL, NOUT )
+ ELSE
+ WRITE( NOUT, FMT = 9989 )PATH
+ END IF
+*
+ ELSE IF( LSAMEN( 2, C2, 'TQ' ) ) THEN
+*
+* TQ: LQT routines for general matrices
+*
+ IF( TSTCHK ) THEN
+ CALL ZCHKLQT( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
+ $ NBVAL, NOUT )
+ ELSE
+ WRITE( NOUT, FMT = 9989 )PATH
+ END IF
+*
+ ELSE IF( LSAMEN( 2, C2, 'XQ' ) ) THEN
+*
+* XQ: LQT routines for triangular-pentagonal matrices
+*
+ IF( TSTCHK ) THEN
+ CALL ZCHKLQTP( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
+ $ NBVAL, NOUT )
+ ELSE
+ WRITE( NOUT, FMT = 9989 )PATH
+ END IF
+*
+ ELSE IF( LSAMEN( 2, C2, 'TS' ) ) THEN
+*
+* TS: QR routines for tall-skinny matrices
+*
+ IF( TSTCHK ) THEN
+ CALL ZCHKTSQR( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
+ $ NBVAL, NOUT )
+ ELSE
+ WRITE( NOUT, FMT = 9989 )PATH
+ END IF
+*
+ ELSE IF( LSAMEN( 2, C2, 'TQ' ) ) THEN
+*
+* TQ: LQT routines for general matrices
+*
+ IF( TSTCHK ) THEN
+ CALL ZCHKLQT( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
+ $ NBVAL, NOUT )
+ ELSE
+ WRITE( NOUT, FMT = 9989 )PATH
+ END IF
+*
+ ELSE IF( LSAMEN( 2, C2, 'XQ' ) ) THEN
+*
+* XQ: LQT routines for triangular-pentagonal matrices
+*
+ IF( TSTCHK ) THEN
+ CALL ZCHKLQTP( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
+ $ NBVAL, NOUT )
+ ELSE
+ WRITE( NOUT, FMT = 9989 )PATH
+ END IF
+*
+ ELSE IF( LSAMEN( 2, C2, 'TS' ) ) THEN
+*
+* TS: QR routines for tall-skinny matrices
+*
+ IF( TSTCHK ) THEN
+ CALL ZCHKTSQR( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
$ NBVAL, NOUT )
ELSE
WRITE( NOUT, FMT = 9989 )PATH
--- /dev/null
+*> \brief \b ZCHKLQT
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZCHKLQT( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
+* NBVAL, NOUT )
+*
+* .. Scalar Arguments ..
+* LOGICAL TSTERR
+* INTEGER NM, NN, NNB, NOUT
+* DOUBLE PRECISION THRESH
+* ..
+* .. Array Arguments ..
+* INTEGER MVAL( * ), NBVAL( * ), NVAL( * )
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> ZCHKLQT tests ZGELQT and ZUNMLQT.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] THRESH
+*> \verbatim
+*> THRESH is DOUBLE PRECISION
+*> The threshold value for the test ratios. A result is
+*> included in the output file if RESULT >= THRESH. To have
+*> every test ratio printed, use THRESH = 0.
+*> \endverbatim
+*>
+*> \param[in] TSTERR
+*> \verbatim
+*> TSTERR is LOGICAL
+*> Flag that indicates whether error exits are to be tested.
+*> \endverbatim
+*>
+*> \param[in] NM
+*> \verbatim
+*> NM is INTEGER
+*> The number of values of M contained in the vector MVAL.
+*> \endverbatim
+*>
+*> \param[in] MVAL
+*> \verbatim
+*> MVAL is INTEGER array, dimension (NM)
+*> The values of the matrix row dimension M.
+*> \endverbatim
+*>
+*> \param[in] NN
+*> \verbatim
+*> NN is INTEGER
+*> The number of values of N contained in the vector NVAL.
+*> \endverbatim
+*>
+*> \param[in] NVAL
+*> \verbatim
+*> NVAL is INTEGER array, dimension (NN)
+*> The values of the matrix column dimension N.
+*> \endverbatim
+*>
+*> \param[in] NNB
+*> \verbatim
+*> NNB is INTEGER
+*> The number of values of NB contained in the vector NBVAL.
+*> \endverbatim
+*>
+*> \param[in] NBVAL
+*> \verbatim
+*> NBVAL is INTEGER array, dimension (NBVAL)
+*> The values of the blocksize NB.
+*> \endverbatim
+*>
+*> \param[in] NOUT
+*> \verbatim
+*> NOUT is INTEGER
+*> The unit number for output.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \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,
+ $ NBVAL, NOUT )
+ IMPLICIT NONE
+*
+* -- LAPACK test routine (version 3.4.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2011
+*
+* .. Scalar Arguments ..
+ LOGICAL TSTERR
+ INTEGER NM, NN, NNB, NOUT
+ DOUBLE PRECISION THRESH
+* ..
+* .. Array Arguments ..
+ INTEGER MVAL( * ), NBVAL( * ), NVAL( * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER NTESTS
+ PARAMETER ( NTESTS = 6 )
+* ..
+* .. Local Scalars ..
+ CHARACTER*3 PATH
+ INTEGER I, J, K, T, M, N, NB, NFAIL, NERRS, NRUN,
+ $ MINMN
+*
+* .. Local Arrays ..
+ DOUBLE PRECISION RESULT( NTESTS )
+* ..
+* .. External Subroutines ..
+ EXTERNAL ALAERH, ALAHD, ALASUM, ZERRLQT, ZLQT04
+* ..
+* .. Scalars in Common ..
+ LOGICAL LERR, OK
+ CHARACTER*32 SRNAMT
+ INTEGER INFOT, NUNIT
+* ..
+* .. Common blocks ..
+ COMMON / INFOC / INFOT, NUNIT, OK, LERR
+ COMMON / SRNAMC / SRNAMT
+* ..
+* .. Executable Statements ..
+*
+* Initialize constants
+*
+ PATH( 1: 1 ) = 'Z'
+ PATH( 2: 3 ) = 'TQ'
+ NRUN = 0
+ NFAIL = 0
+ NERRS = 0
+*
+* Test the error exits
+*
+ IF( TSTERR ) CALL ZERRLQT( PATH, NOUT )
+ INFOT = 0
+*
+* Do for each value of M in MVAL.
+*
+ DO I = 1, NM
+ M = MVAL( I )
+*
+* Do for each value of N in NVAL.
+*
+ DO J = 1, NN
+ N = NVAL( J )
+*
+* Do for each possible value of NB
+*
+ MINMN = MIN( M, N )
+ DO K = 1, NNB
+ NB = NBVAL( K )
+*
+* Test ZGELQT and ZUNMLQT
+*
+ IF( (NB.LE.MINMN).AND.(NB.GT.0) ) THEN
+ CALL ZLQT04( M, N, NB, RESULT )
+*
+* Print information about the tests that did not
+* pass the threshold.
+*
+ DO T = 1, NTESTS
+ IF( RESULT( T ).GE.THRESH ) THEN
+ IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
+ $ CALL ALAHD( NOUT, PATH )
+ WRITE( NOUT, FMT = 9999 )M, N, NB,
+ $ T, RESULT( T )
+ NFAIL = NFAIL + 1
+ END IF
+ END DO
+ NRUN = NRUN + NTESTS
+ END IF
+ END DO
+ END DO
+ END DO
+*
+* Print a summary of the results.
+*
+ CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
+*
+ 9999 FORMAT( ' M=', I5, ', N=', I5, ', NB=', I4,
+ $ ' test(', I2, ')=', G12.5 )
+ RETURN
+*
+* End of ZCHKLQT
+*
+ END
--- /dev/null
+*> \brief \b ZCHKLQTP
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZCHKLQTP( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
+* NBVAL, NOUT )
+*
+* .. Scalar Arguments ..
+* LOGICAL TSTERR
+* INTEGER NM, NN, NNB, NOUT
+* DOUBLE PRECISION THRESH
+* ..
+* .. Array Arguments ..
+* INTEGER MVAL( * ), NBVAL( * ), NVAL( * )
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> ZCHKLQTP tests ZTPLQT and ZTPMLQT.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] THRESH
+*> \verbatim
+*> THRESH is DOUBLE PRECISION
+*> The threshold value for the test ratios. A result is
+*> included in the output file if RESULT >= THRESH. To have
+*> every test ratio printed, use THRESH = 0.
+*> \endverbatim
+*>
+*> \param[in] TSTERR
+*> \verbatim
+*> TSTERR is LOGICAL
+*> Flag that indicates whether error exits are to be tested.
+*> \endverbatim
+*>
+*> \param[in] NM
+*> \verbatim
+*> NM is INTEGER
+*> The number of values of M contained in the vector MVAL.
+*> \endverbatim
+*>
+*> \param[in] MVAL
+*> \verbatim
+*> MVAL is INTEGER array, dimension (NM)
+*> The values of the matrix row dimension M.
+*> \endverbatim
+*>
+*> \param[in] NN
+*> \verbatim
+*> NN is INTEGER
+*> The number of values of N contained in the vector NVAL.
+*> \endverbatim
+*>
+*> \param[in] NVAL
+*> \verbatim
+*> NVAL is INTEGER array, dimension (NN)
+*> The values of the matrix column dimension N.
+*> \endverbatim
+*>
+*> \param[in] NNB
+*> \verbatim
+*> NNB is INTEGER
+*> The number of values of NB contained in the vector NBVAL.
+*> \endverbatim
+*>
+*> \param[in] NBVAL
+*> \verbatim
+*> NBVAL is INTEGER array, dimension (NBVAL)
+*> The values of the blocksize NB.
+*> \endverbatim
+*>
+*> \param[in] NOUT
+*> \verbatim
+*> NOUT is INTEGER
+*> The unit number for output.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \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,
+ $ NBVAL, NOUT )
+ IMPLICIT NONE
+*
+* -- LAPACK test routine (version 3.4.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2011
+*
+* .. Scalar Arguments ..
+ LOGICAL TSTERR
+ INTEGER NM, NN, NNB, NOUT
+ DOUBLE PRECISION THRESH
+* ..
+* .. Array Arguments ..
+ INTEGER MVAL( * ), NBVAL( * ), NVAL( * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER NTESTS
+ PARAMETER ( NTESTS = 6 )
+* ..
+* .. Local Scalars ..
+ CHARACTER*3 PATH
+ INTEGER I, J, K, L, T, M, N, NB, NFAIL, NERRS, NRUN,
+ $ MINMN
+* ..
+* .. Local Arrays ..
+ DOUBLE PRECISION RESULT( NTESTS )
+* ..
+* .. External Subroutines ..
+ EXTERNAL ALAERH, ALAHD, ALASUM, ZERRLQTP, ZLQT04
+* ..
+* .. Scalars in Common ..
+ LOGICAL LERR, OK
+ CHARACTER*32 SRNAMT
+ INTEGER INFOT, NUNIT
+* ..
+* .. Common blocks ..
+ COMMON / INFOC / INFOT, NUNIT, OK, LERR
+ COMMON / SRNAMC / SRNAMT
+* ..
+* .. Executable Statements ..
+*
+* Initialize constants
+*
+ PATH( 1: 1 ) = 'Z'
+ PATH( 2: 3 ) = 'XQ'
+ NRUN = 0
+ NFAIL = 0
+ NERRS = 0
+*
+* Test the error exits
+*
+ IF( TSTERR ) CALL ZERRLQTP( PATH, NOUT )
+ INFOT = 0
+*
+* Do for each value of M
+*
+ DO I = 1, NM
+ M = MVAL( I )
+*
+* Do for each value of N
+*
+ DO J = 1, NN
+ N = NVAL( J )
+*
+* Do for each value of L
+*
+ 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 )
+*
+* Print information about the tests that did not
+* pass the threshold.
+*
+ DO T = 1, NTESTS
+ IF( RESULT( T ).GE.THRESH ) THEN
+ IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
+ $ CALL ALAHD( NOUT, PATH )
+ WRITE( NOUT, FMT = 9999 )M, N, NB, L,
+ $ T, RESULT( T )
+ NFAIL = NFAIL + 1
+ END IF
+ END DO
+ NRUN = NRUN + NTESTS
+ END IF
+ END DO
+ END DO
+ END DO
+ END DO
+*
+* Print a summary of the results.
+*
+ CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
+*
+ 9999 FORMAT( ' M=', I5, ', N=', I5, ', NB=', I4,' L=', I4,
+ $ ' test(', I2, ')=', G12.5 )
+ RETURN
+*
+* End of ZCHKLQTP
+*
+ END
\ No newline at end of file
--- /dev/null
+*> \brief \b DCHKQRT
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZCHKTSQR( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
+* NBVAL, NOUT )
+*
+* .. Scalar Arguments ..
+* LOGICAL TSTERR
+* INTEGER NM, NN, NNB, NOUT
+* DOUBLE PRECISION THRESH
+* ..
+* .. Array Arguments ..
+* INTEGER MVAL( * ), NBVAL( * ), NVAL( * )
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> ZCHKTSQR tests ZGEQR and ZGEMQR.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] THRESH
+*> \verbatim
+*> THRESH is DOUBLE PRECISION
+*> The threshold value for the test ratios. A result is
+*> included in the output file if RESULT >= THRESH. To have
+*> every test ratio printed, use THRESH = 0.
+*> \endverbatim
+*>
+*> \param[in] TSTERR
+*> \verbatim
+*> TSTERR is LOGICAL
+*> Flag that indicates whether error exits are to be tested.
+*> \endverbatim
+*>
+*> \param[in] NM
+*> \verbatim
+*> NM is INTEGER
+*> The number of values of M contained in the vector MVAL.
+*> \endverbatim
+*>
+*> \param[in] MVAL
+*> \verbatim
+*> MVAL is INTEGER array, dimension (NM)
+*> The values of the matrix row dimension M.
+*> \endverbatim
+*>
+*> \param[in] NN
+*> \verbatim
+*> NN is INTEGER
+*> The number of values of N contained in the vector NVAL.
+*> \endverbatim
+*>
+*> \param[in] NVAL
+*> \verbatim
+*> NVAL is INTEGER array, dimension (NN)
+*> The values of the matrix column dimension N.
+*> \endverbatim
+*>
+*> \param[in] NNB
+*> \verbatim
+*> NNB is INTEGER
+*> The number of values of NB contained in the vector NBVAL.
+*> \endverbatim
+*>
+*> \param[in] NBVAL
+*> \verbatim
+*> NBVAL is INTEGER array, dimension (NBVAL)
+*> The values of the blocksize NB.
+*> \endverbatim
+*>
+*> \param[in] NOUT
+*> \verbatim
+*> NOUT is INTEGER
+*> The unit number for output.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \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,
+ $ NBVAL, NOUT )
+ IMPLICIT NONE
+*
+* -- LAPACK test routine (version 3.4.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2011
+*
+* .. Scalar Arguments ..
+ LOGICAL TSTERR
+ INTEGER NM, NN, NNB, NOUT
+ DOUBLE PRECISION THRESH
+* ..
+* .. Array Arguments ..
+ INTEGER MVAL( * ), NBVAL( * ), NVAL( * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER NTESTS
+ PARAMETER ( NTESTS = 6 )
+* ..
+* .. Local Scalars ..
+ CHARACTER*3 PATH
+ INTEGER I, J, K, T, M, N, NB, NFAIL, NERRS, NRUN, INB,
+ $ MINMN, MB, IMB
+*
+* .. Local Arrays ..
+ DOUBLE PRECISION RESULT( NTESTS )
+* ..
+* .. External Subroutines ..
+ EXTERNAL ALAERH, ALAHD, ALASUM, DERRTSQR,
+ $ DTSQR01, XLAENV
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Scalars in Common ..
+ LOGICAL LERR, OK
+ CHARACTER*32 SRNAMT
+ INTEGER INFOT, NUNIT
+* ..
+* .. Common blocks ..
+ COMMON / INFOC / INFOT, NUNIT, OK, LERR
+ COMMON / SRNAMC / SRNAMT
+* ..
+* .. Executable Statements ..
+*
+* Initialize constants
+*
+ PATH( 1: 1 ) = 'Z'
+ PATH( 2: 3 ) = 'TS'
+ NRUN = 0
+ NFAIL = 0
+ NERRS = 0
+*
+* Test the error exits
+*
+ IF( TSTERR ) CALL ZERRTSQR( PATH, NOUT )
+ INFOT = 0
+*
+* Do for each value of M in MVAL.
+*
+ DO I = 1, NM
+ M = MVAL( I )
+*
+* Do for each value of N in NVAL.
+*
+ DO J = 1, NN
+ N = NVAL( J )
+ IF (MIN(M,N).NE.0) THEN
+ DO INB = 1, NNB
+ MB = NBVAL( INB )
+ CALL XLAENV( 1, MB )
+ DO IMB = 1, NNB
+ NB = NBVAL( IMB )
+ CALL XLAENV( 2, NB )
+*
+* Test ZGEQR and ZGEMQR
+*
+ CALL ZTSQR01( 'TS', M, N, MB, NB, RESULT )
+*
+* Print information about the tests that did not
+* pass the threshold.
+*
+ DO T = 1, NTESTS
+ IF( RESULT( T ).GE.THRESH ) THEN
+ IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
+ $ CALL ALAHD( NOUT, PATH )
+ WRITE( NOUT, FMT = 9999 )M, N, MB, NB,
+ $ T, RESULT( T )
+ NFAIL = NFAIL + 1
+ END IF
+ END DO
+ NRUN = NRUN + NTESTS
+ END DO
+ END DO
+ END IF
+ END DO
+ END DO
+*
+* Do for each value of M in MVAL.
+*
+ DO I = 1, NM
+ M = MVAL( I )
+*
+* Do for each value of N in NVAL.
+*
+ DO J = 1, NN
+ N = NVAL( J )
+ IF (MIN(M,N).NE.0) THEN
+ DO INB = 1, NNB
+ MB = NBVAL( INB )
+ CALL XLAENV( 1, MB )
+ DO IMB = 1, NNB
+ NB = NBVAL( IMB )
+ CALL XLAENV( 2, NB )
+*
+* Test ZGELQ and ZGEMLQ
+*
+ CALL ZTSQR01( 'SW', M, N, MB, NB, RESULT )
+*
+* Print information about the tests that did not
+* pass the threshold.
+*
+ DO T = 1, NTESTS
+ IF( RESULT( T ).GE.THRESH ) THEN
+ IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
+ $ CALL ALAHD( NOUT, PATH )
+ WRITE( NOUT, FMT = 9998 )M, N, MB, NB,
+ $ T, RESULT( T )
+ NFAIL = NFAIL + 1
+ END IF
+ END DO
+ NRUN = NRUN + NTESTS
+ END DO
+ END DO
+ END IF
+ END DO
+ END DO
+*
+* Print a summary of the results.
+*
+ CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
+*
+ 9999 FORMAT( 'TS: M=', I5, ', N=', I5, ', MB=', I5,
+ $ ', NB=', I5,' test(', I2, ')=', G12.5 )
+ 9998 FORMAT( 'SW: M=', I5, ', N=', I5, ', MB=', I5,
+ $ ', NB=', I5,' test(', I2, ')=', G12.5 )
+ RETURN
+*
+* End of ZCHKQRT
+*
+ 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 ZDRVLS( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, NNB,
* NBVAL, NXVAL, THRESH, TSTERR, A, COPYA, B,
* COPYB, C, S, COPYS, WORK, RWORK, IWORK, NOUT )
-*
+*
* .. Scalar Arguments ..
* LOGICAL TSTERR
* INTEGER NM, NN, NNB, NNS, NOUT
* COMPLEX*16 A( * ), B( * ), C( * ), COPYA( * ), COPYB( * ),
* $ 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 2015
*
*
* .. Parameters ..
INTEGER NTESTS
- PARAMETER ( NTESTS = 14 )
+ PARAMETER ( NTESTS = 16 )
INTEGER SMLSIZ
PARAMETER ( SMLSIZ = 25 )
DOUBLE PRECISION ONE, ZERO
INTEGER CRANK, I, IM, IN, INB, INFO, INS, IRANK,
$ ISCALE, ITRAN, ITYPE, J, K, LDA, LDB, LDWORK,
$ LWLSY, LWORK, M, MNMIN, N, NB, NCOLS, NERRS,
- $ NFAIL, NRHS, NROWS, NRUN, RANK
+ $ NFAIL, NRHS, NROWS, NRUN, RANK, MB, LWTS
DOUBLE PRECISION EPS, NORMA, NORMB, RCOND
* ..
* .. Local Arrays ..
EXTERNAL ALAERH, ALAHD, ALASVM, DAXPY, DLASRT, XLAENV,
$ ZDSCAL, ZERRLS, ZGELS, ZGELSD, ZGELSS,
$ ZGELSY, ZGEMM, ZLACPY, ZLARNV, ZQRT13, ZQRT15,
- $ ZQRT16
+ $ ZQRT16, ZGETSLS
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, MAX, MIN, SQRT
*
DO 130 IN = 1, NN
N = NVAL( IN )
- MNMIN = MIN( M, N )
+ MNMIN = MAX(MIN( M, N ),1)
LDB = MAX( 1, M, N )
+ MB = (MNMIN+1)
+ IF(MINMN.NE.MB) THEN
+ LWTS = (((LDB-MB)/(MB-MNMIN))*MNMIN+LDB*2)*MB+5
+ ELSE
+ LWTS = 2*MINMN+5
+ END IF
*
DO 120 INS = 1, NNS
NRHS = NSVAL( INS )
LWORK = MAX( 1, ( M+NRHS )*( N+2 ), ( N+NRHS )*( M+2 ),
- $ M*N+4*MNMIN+MAX( M, N ), 2*N+M )
+ $ M*N+4*MNMIN+MAX( M, N ), 2*N+M, LWTS )
*
DO 110 IRANK = 1, 2
DO 100 ISCALE = 1, 3
NRUN = NRUN + 2
30 CONTINUE
40 CONTINUE
+*
+*
+* Test ZGETSLS
+*
+* Generate a matrix of scaling type ISCALE
+*
+ CALL ZQRT13( ISCALE, M, N, COPYA, LDA, NORMA,
+ $ ISEED )
+ DO 65 INB = 1, NNB
+ MB = NBVAL( INB )
+ CALL XLAENV( 1, MB )
+ DO 62 IMB = 1, NNB
+ NB = NBVAL( IMB )
+ CALL XLAENV( 2, NB )
+*
+ DO 60 ITRAN = 1, 2
+ IF( ITRAN.EQ.1 ) THEN
+ TRANS = 'N'
+ NROWS = M
+ NCOLS = N
+ ELSE
+ TRANS = 'C'
+ NROWS = N
+ NCOLS = M
+ END IF
+ LDWORK = MAX( 1, NCOLS )
+*
+* Set up a consistent rhs
+*
+ IF( NCOLS.GT.0 ) THEN
+ CALL ZLARNV( 2, ISEED, NCOLS*NRHS,
+ $ WORK )
+ CALL ZSCAL( NCOLS*NRHS,
+ $ ONE / DBLE( NCOLS ), WORK,
+ $ 1 )
+ END IF
+ CALL ZGEMM( TRANS, 'No transpose', NROWS,
+ $ NRHS, NCOLS, CONE, COPYA, LDA,
+ $ WORK, LDWORK, CZERO, B, LDB )
+ CALL ZLACPY( 'Full', NROWS, NRHS, B, LDB,
+ $ COPYB, LDB )
+*
+* Solve LS or overdetermined system
+*
+ IF( M.GT.0 .AND. N.GT.0 ) THEN
+ CALL ZLACPY( 'Full', M, N, COPYA, LDA,
+ $ A, LDA )
+ CALL ZLACPY( 'Full', NROWS, NRHS,
+ $ COPYB, LDB, B, LDB )
+ END IF
+ SRNAMT = 'DGETSLS '
+ CALL ZGETSLS( TRANS, M, N, NRHS, A,
+ $ LDA, B, LDB, WORK, LWORK, INFO )
+ IF( INFO.NE.0 )
+ $ CALL ALAERH( PATH, 'ZGETSLS ', INFO, 0,
+ $ TRANS, M, N, NRHS, -1, NB,
+ $ ITYPE, NFAIL, NERRS,
+ $ NOUT )
+*
+* Check correctness of results
+*
+ LDWORK = MAX( 1, NROWS )
+ IF( NROWS.GT.0 .AND. NRHS.GT.0 )
+ $ CALL ZLACPY( 'Full', NROWS, NRHS,
+ $ COPYB, LDB, C, LDB )
+ CALL ZQRT16( TRANS, M, N, NRHS, COPYA,
+ $ LDA, B, LDB, C, LDB, WORK,
+ $ RESULT( 15 ) )
+*
+ IF( ( ITRAN.EQ.1 .AND. M.GE.N ) .OR.
+ $ ( ITRAN.EQ.2 .AND. M.LT.N ) ) THEN
+*
+* Solving LS system
+*
+ RESULT( 16 ) = ZQRT17( TRANS, 1, M, N,
+ $ NRHS, COPYA, LDA, B, LDB,
+ $ COPYB, LDB, C, WORK,
+ $ LWORK )
+ ELSE
+*
+* Solving overdetermined system
+*
+ RESULT( 16 ) = ZQRT14( TRANS, M, N,
+ $ NRHS, COPYA, LDA, B, LDB,
+ $ WORK, LWORK )
+ END IF
+*
+* Print information about the tests that
+* did not pass the threshold.
+*
+ DO 50 K = 15, 16
+ IF( RESULT( K ).GE.THRESH ) THEN
+ IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
+ $ CALL ALAHD( NOUT, PATH )
+ WRITE( NOUT, FMT = 9997 )TRANS, M,
+ $ N, NRHS, MB, NB, ITYPE, K,
+ $ RESULT( K )
+ NFAIL = NFAIL + 1
+ END IF
+ 50 CONTINUE
+ NRUN = NRUN + 2
+ 60 CONTINUE
+ 62 CONTINUE
+ 65 CONTINUE
END IF
*
* Generate a matrix of scaling type ISCALE and rank
* Print information about the tests that did not
* pass the threshold.
*
- DO 80 K = 3, NTESTS
+ DO 80 K = 3, 14
IF( RESULT( K ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
$ ', 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,
+ $ ', test(', I2, ')=', G12.5 )
RETURN
*
* End of ZDRVLS
--- /dev/null
+*> \brief \b ZERLQT
+*
+* =========== DOCUMENTATION ===========
+*
+* 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:
+* =============
+*>
+*> \verbatim
+*>
+*> ZERRLQT tests the error exits for the COMPLEX routines
+*> that use the LQT decomposition of a general matrix.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] PATH
+*> \verbatim
+*> PATH is CHARACTER*3
+*> The LAPACK path name for the routines to be tested.
+*> \endverbatim
+*>
+*> \param[in] NUNIT
+*> \verbatim
+*> NUNIT is INTEGER
+*> The unit number for output.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2011
+*
+*> \ingroup double_lin
+*
+* =====================================================================
+ SUBROUTINE ZERRLQT( PATH, NUNIT )
+ IMPLICIT NONE
+*
+* -- LAPACK test routine (version 3.4.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2011
+*
+* .. Scalar Arguments ..
+ CHARACTER*3 PATH
+ INTEGER NUNIT
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER NMAX
+ PARAMETER ( NMAX = 2 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, INFO, J
+* ..
+* .. Local Arrays ..
+ COMPLEX*16 A( NMAX, NMAX ), T( NMAX, NMAX ), W( NMAX ),
+ $ C( NMAX, NMAX )
+* ..
+* .. External Subroutines ..
+ EXTERNAL ALAESM, CHKXER, ZGELQT3, ZGELQT,
+ $ ZGEMLQT
+* ..
+* .. Scalars in Common ..
+ LOGICAL LERR, OK
+ CHARACTER*32 SRNAMT
+ INTEGER INFOT, NOUT
+* ..
+* .. Common blocks ..
+ COMMON / INFOC / INFOT, NOUT, OK, LERR
+ COMMON / SRNAMC / SRNAMT
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC DBLE, DCMPLX
+* ..
+* .. Executable Statements ..
+*
+ NOUT = NUNIT
+ WRITE( NOUT, FMT = * )
+*
+* Set the variables to innocuous values.
+*
+ DO J = 1, NMAX
+ DO I = 1, NMAX
+ A( I, J ) = 1.D0 / DCMPLX( DBLE( I+J ), 0.D0 )
+ C( I, J ) = 1.D0 / DCMPLX( DBLE( I+J ), 0.D0 )
+ T( I, J ) = 1.D0 / DCMPLX( DBLE( I+J ), 0.D0 )
+ END DO
+ W( J ) = 0.D0
+ END DO
+ OK = .TRUE.
+*
+* Error exits for LQT factorization
+*
+* ZGELQT
+*
+ SRNAMT = 'ZGELQT'
+ INFOT = 1
+ CALL ZGELQT( -1, 0, 1, A, 1, T, 1, W, INFO )
+ CALL CHKXER( 'ZGELQT', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL ZGELQT( 0, -1, 1, A, 1, T, 1, W, INFO )
+ CALL CHKXER( 'ZGELQT', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL ZGELQT( 0, 0, 0, A, 1, T, 1, W, INFO )
+ CALL CHKXER( 'ZGELQT', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL ZGELQT( 2, 1, 1, A, 1, T, 1, W, INFO )
+ CALL CHKXER( 'ZGELQT', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL ZGELQT( 2, 2, 2, A, 2, T, 1, W, INFO )
+ CALL CHKXER( 'ZGELQT', INFOT, NOUT, LERR, OK )
+*
+* ZGELQT3
+*
+ SRNAMT = 'ZGELQT3'
+ INFOT = 1
+ CALL ZGELQT3( -1, 0, A, 1, T, 1, INFO )
+ CALL CHKXER( 'ZGELQT3', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL ZGELQT3( 0, -1, A, 1, T, 1, INFO )
+ CALL CHKXER( 'ZGELQT3', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL ZGELQT3( 2, 2, A, 1, T, 1, INFO )
+ CALL CHKXER( 'ZGELQT3', INFOT, NOUT, LERR, OK )
+ INFOT = 6
+ CALL ZGELQT3( 2, 2, A, 2, T, 1, INFO )
+ CALL CHKXER( 'ZGELQT3', INFOT, NOUT, LERR, OK )
+*
+* ZGEMLQT
+*
+ SRNAMT = 'ZGEMLQT'
+ INFOT = 1
+ CALL ZGEMLQT( '/', 'N', 0, 0, 0, 1, A, 1, T, 1, C, 1, W, INFO )
+ CALL CHKXER( 'ZGEMLQT', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL ZGEMLQT( 'L', '/', 0, 0, 0, 1, A, 1, T, 1, C, 1, W, INFO )
+ CALL CHKXER( 'ZGEMLQT', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL ZGEMLQT( 'L', 'N', -1, 0, 0, 1, A, 1, T, 1, C, 1, W, INFO )
+ CALL CHKXER( 'ZGEMLQT', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL ZGEMLQT( 'L', 'N', 0, -1, 0, 1, A, 1, T, 1, C, 1, W, INFO )
+ CALL CHKXER( 'ZGEMLQT', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL ZGEMLQT( 'L', 'N', 0, 0, -1, 1, A, 1, T, 1, C, 1, W, INFO )
+ CALL CHKXER( 'ZGEMLQT', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL ZGEMLQT( 'R', 'N', 0, 0, -1, 1, A, 1, T, 1, C, 1, W, INFO )
+ CALL CHKXER( 'ZGEMLQT', INFOT, NOUT, LERR, OK )
+ INFOT = 6
+ CALL ZGEMLQT( 'L', 'N', 0, 0, 0, 0, A, 1, T, 1, C, 1, W, INFO )
+ CALL CHKXER( 'ZGEMLQT', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL ZGEMLQT( 'R', 'N', 2, 2, 2, 1, A, 1, T, 1, C, 1, W, INFO )
+ CALL CHKXER( 'ZGEMLQT', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL ZGEMLQT( 'L', 'N', 2, 2, 2, 1, A, 1, T, 1, C, 1, W, INFO )
+ CALL CHKXER( 'ZGEMLQT', INFOT, NOUT, LERR, OK )
+ INFOT = 10
+ CALL ZGEMLQT( 'R', 'N', 1, 1, 1, 1, A, 1, T, 0, C, 1, W, INFO )
+ CALL CHKXER( 'ZGEMLQT', INFOT, NOUT, LERR, OK )
+ INFOT = 12
+ CALL ZGEMLQT( 'L', 'N', 1, 1, 1, 1, A, 1, T, 1, C, 0, W, INFO )
+ CALL CHKXER( 'ZGEMLQT', INFOT, NOUT, LERR, OK )
+*
+* Print a summary line.
+*
+ CALL ALAESM( PATH, OK, NOUT )
+*
+ RETURN
+*
+* End of ZERRLQT
+*
+ END
--- /dev/null
+*> \brief \b ZERRLQTP
+*
+* =========== DOCUMENTATION ===========
+*
+* 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:
+* =============
+*>
+*> \verbatim
+*>
+*> ZERRLQTP tests the error exits for the complex routines
+*> that use the LQT decomposition of a triangular-pentagonal matrix.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] PATH
+*> \verbatim
+*> PATH is CHARACTER*3
+*> The LAPACK path name for the routines to be tested.
+*> \endverbatim
+*>
+*> \param[in] NUNIT
+*> \verbatim
+*> NUNIT is INTEGER
+*> The unit number for output.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2011
+*
+*> \ingroup double_lin
+*
+* =====================================================================
+ SUBROUTINE ZERRLQTP( PATH, NUNIT )
+ IMPLICIT NONE
+*
+* -- LAPACK test routine (version 3.4.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2011
+*
+* .. Scalar Arguments ..
+ CHARACTER*3 PATH
+ INTEGER NUNIT
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER NMAX
+ PARAMETER ( NMAX = 2 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, INFO, J
+* ..
+* .. Local Arrays ..
+ COMPLEX*16 A( NMAX, NMAX ), T( NMAX, NMAX ), W( NMAX ),
+ $ B( NMAX, NMAX ), C( NMAX, NMAX )
+* ..
+* .. External Subroutines ..
+ EXTERNAL ALAESM, CHKXER, ZTPLQT2, ZTPLQT,
+ $ ZTPMLQT
+* ..
+* .. Scalars in Common ..
+ LOGICAL LERR, OK
+ CHARACTER*32 SRNAMT
+ INTEGER INFOT, NOUT
+* ..
+* .. Common blocks ..
+ COMMON / INFOC / INFOT, NOUT, OK, LERR
+ COMMON / SRNAMC / SRNAMT
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC DBLE, DCMPLX
+* ..
+* .. Executable Statements ..
+*
+ NOUT = NUNIT
+ WRITE( NOUT, FMT = * )
+*
+* Set the variables to innocuous values.
+*
+ DO J = 1, NMAX
+ DO I = 1, NMAX
+ A( I, J ) = 1.D0 / DCMPLX( DBLE( I+J ), 0.D0 )
+ C( I, J ) = 1.D0 / DCMPLX( DBLE( I+J ), 0.D0 )
+ T( I, J ) = 1.D0 / DCMPLX( DBLE( I+J ), 0.D0 )
+ END DO
+ W( J ) = 0.0
+ END DO
+ OK = .TRUE.
+*
+* Error exits for TPLQT factorization
+*
+* ZTPLQT
+*
+ SRNAMT = 'ZTPLQT'
+ INFOT = 1
+ CALL ZTPLQT( -1, 1, 0, 1, A, 1, B, 1, T, 1, W, INFO )
+ CALL CHKXER( 'ZTPLQT', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL ZTPLQT( 1, -1, 0, 1, A, 1, B, 1, T, 1, W, INFO )
+ CALL CHKXER( 'ZTPLQT', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL ZTPLQT( 0, 1, -1, 1, A, 1, B, 1, T, 1, W, INFO )
+ CALL CHKXER( 'ZTPLQT', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL ZTPLQT( 0, 1, 1, 1, A, 1, B, 1, T, 1, W, INFO )
+ CALL CHKXER( 'ZTPLQT', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL ZTPLQT( 0, 1, 0, 0, A, 1, B, 1, T, 1, W, INFO )
+ CALL CHKXER( 'ZTPLQT', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL ZTPLQT( 1, 1, 0, 2, A, 1, B, 1, T, 1, W, INFO )
+ CALL CHKXER( 'ZTPLQT', INFOT, NOUT, LERR, OK )
+ INFOT = 6
+ CALL ZTPLQT( 2, 1, 0, 2, A, 1, B, 1, T, 1, W, INFO )
+ CALL CHKXER( 'ZTPLQT', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL ZTPLQT( 2, 1, 0, 1, A, 2, B, 1, T, 1, W, INFO )
+ CALL CHKXER( 'ZTPLQT', INFOT, NOUT, LERR, OK )
+ INFOT = 10
+ CALL ZTPLQT( 2, 2, 1, 2, A, 2, B, 2, T, 1, W, INFO )
+ CALL CHKXER( 'ZTPLQT', INFOT, NOUT, LERR, OK )
+*
+* ZTPLQT2
+*
+ SRNAMT = 'ZTPLQT2'
+ INFOT = 1
+ CALL ZTPLQT2( -1, 0, 0, A, 1, B, 1, T, 1, INFO )
+ CALL CHKXER( 'ZTPLQT2', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL ZTPLQT2( 0, -1, 0, A, 1, B, 1, T, 1, INFO )
+ CALL CHKXER( 'ZTPLQT2', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL ZTPLQT2( 0, 0, -1, A, 1, B, 1, T, 1, INFO )
+ CALL CHKXER( 'ZTPLQT2', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL ZTPLQT2( 2, 2, 0, A, 1, B, 2, T, 2, INFO )
+ CALL CHKXER( 'ZTPLQT2', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL ZTPLQT2( 2, 2, 0, A, 2, B, 1, T, 2, INFO )
+ CALL CHKXER( 'ZTPLQT2', INFOT, NOUT, LERR, OK )
+ INFOT = 9
+ CALL ZTPLQT2( 2, 2, 0, A, 2, B, 2, T, 1, INFO )
+ CALL CHKXER( 'ZTPLQT2', INFOT, NOUT, LERR, OK )
+*
+* ZTPMLQT
+*
+ SRNAMT = 'ZTPMLQT'
+ INFOT = 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,
+ $ 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,
+ $ 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,
+ $ 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,
+ $ W, INFO )
+ INFOT = 6
+ 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,
+ $ 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,
+ $ 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,
+ $ 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,
+ $ 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,
+ $ W, INFO )
+ CALL CHKXER( 'ZTPMLQT', INFOT, NOUT, LERR, OK )
+*
+* Print a summary line.
+*
+ CALL ALAESM( PATH, OK, NOUT )
+*
+ RETURN
+*
+* End of ZERRLQT
+*
+ END
--- /dev/null
+*> \brief \b ZERRTSQR
+*
+* =========== DOCUMENTATION ===========
+*
+* 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:
+* =============
+*>
+*> \verbatim
+*>
+*> ZERRTSQR tests the error exits for the ZOUBLE PRECISION routines
+*> that use the TSQR decomposition of a general matrix.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] PATH
+*> \verbatim
+*> PATH is CHARACTER*3
+*> The LAPACK path name for the routines to be tested.
+*> \endverbatim
+*>
+*> \param[in] NUNIT
+*> \verbatim
+*> NUNIT is INTEGER
+*> The unit number for output.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Zenver
+*> \author NAG Ltd.
+*
+*> \date November 2011
+*
+*> \ingroup double_lin
+*
+* =====================================================================
+ SUBROUTINE ZERRTSQR( PATH, NUNIT )
+ IMPLICIT NONE
+*
+* -- LAPACK test routine (version 3.4.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2011
+*
+* .. Scalar Arguments ..
+ CHARACTER*3 PATH
+ INTEGER NUNIT
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER NMAX
+ PARAMETER ( NMAX = 2 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, INFO, J, NB
+* ..
+* .. Local Arrays ..
+ COMPLEX*16 A( NMAX, NMAX ), T( NMAX, NMAX ), W( NMAX ),
+ $ C( NMAX, NMAX ), TAU(NMAX)
+* ..
+* .. External Subroutines ..
+ EXTERNAL ALAESM, CHKXER, ZGEQR,
+ $ ZGEMQR, ZGELQ, ZGEMLQ
+* ..
+* .. Scalars in Common ..
+ LOGICAL LERR, OK
+ CHARACTER*32 SRNAMT
+ INTEGER INFOT, NOUT
+* ..
+* .. Common blocks ..
+ COMMON / INFOC / INFOT, NOUT, OK, LERR
+ COMMON / SRNAMC / SRNAMT
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC DBLE
+* ..
+* .. Executable Statements ..
+*
+ NOUT = NUNIT
+ WRITE( NOUT, FMT = * )
+*
+* Set the variables to innocuous values.
+*
+ DO J = 1, NMAX
+ DO I = 1, NMAX
+ A( I, J ) = 1.D0 / DBLE( I+J )
+ C( I, J ) = 1.D0 / DBLE( I+J )
+ T( I, J ) = 1.D0 / DBLE( I+J )
+ END DO
+ W( J ) = 0.D0
+ END DO
+ OK = .TRUE.
+*
+* Error exits for TS factorization
+*
+* ZGEQR
+*
+ SRNAMT = 'ZGEQR'
+ INFOT = 1
+ CALL ZGEQR( -1, 0, A, 1, TAU, 1, W, 1, INFO )
+ CALL CHKXER( 'ZGEQR', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL ZGEQR( 0, -1, A, 1, TAU, 1, W, 1, INFO )
+ CALL CHKXER( 'ZGEQR', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL ZGEQR( 1, 1, A, 0, TAU, 1, W, 1, INFO )
+ CALL CHKXER( 'ZGEQR', INFOT, NOUT, LERR, OK )
+ INFOT = 6
+ CALL ZGEQR( 3, 2, A, 3, TAU, 1, W, 1, INFO )
+ CALL CHKXER( 'ZGEQR', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL ZGEQR( 3, 2, A, 3, TAU, 8, W, 0, INFO )
+ CALL CHKXER( 'ZGEQR', INFOT, NOUT, LERR, OK )
+*
+* ZGEMQR
+*
+ TAU(1)=1
+ TAU(2)=1
+ SRNAMT = 'ZGEMQR'
+ NB=1
+ INFOT = 1
+ CALL ZGEMQR( '/', 'N', 0, 0, 0, A, 1, TAU, 1, C, 1, W, 1,INFO)
+ CALL CHKXER( 'ZGEMQR', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL ZGEMQR( 'L', '/', 0, 0, 0, A, 1, TAU, 1, C, 1, W, 1,INFO)
+ CALL CHKXER( 'ZGEMQR', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL ZGEMQR( 'L', 'N', -1, 0, 0, A, 1, TAU, 1, C, 1, W,1,INFO)
+ CALL CHKXER( 'ZGEMQR', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL ZGEMQR( 'L', 'N', 0, -1, 0, A, 1, TAU, 1, C, 1, W,1,INFO)
+ CALL CHKXER( 'ZGEMQR', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL ZGEMQR( 'L', 'N', 0, 0, -1, A, 1, TAU, 1, C, 1, W,1,INFO)
+ CALL CHKXER( 'ZGEMQR', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL ZGEMQR( 'R', 'N', 0, 0, -1, A, 1, TAU, 1, C, 1, W,1,INFO)
+ CALL CHKXER( 'ZGEMQR', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL ZGEMQR( 'L', 'N', 2, 1, 0, A, 0, TAU, 1, C, 1, W, 1,INFO)
+ CALL CHKXER( 'ZGEMQR', INFOT, NOUT, LERR, OK )
+ INFOT = 9
+ CALL ZGEMQR( 'R', 'N', 2, 2, 1, A, 1, TAU, 0, C, 1, W, 1,INFO)
+ CALL CHKXER( 'ZGEMQR', INFOT, NOUT, LERR, OK )
+ INFOT = 9
+ CALL ZGEMQR( 'L', 'N', 2, 2, 1, A, 1, TAU, 0, C, 1, W, 1,INFO)
+ CALL CHKXER( 'ZGEMQR', INFOT, NOUT, LERR, OK )
+ INFOT = 11
+ CALL ZGEMQR( 'L', 'N', 2, 1, 1, A, 1, TAU, 6, C, 0, W, 1,INFO)
+ CALL CHKXER( 'ZGEMQR', INFOT, NOUT, LERR, OK )
+ INFOT = 13
+ CALL ZGEMQR( 'L', 'N', 2, 2, 1, A, 2, TAU, 6, C, 2, W, 0,INFO)
+ CALL CHKXER( 'ZGEMQR', INFOT, NOUT, LERR, OK )
+*
+* ZGELQ
+*
+ SRNAMT = 'ZGELQ'
+ INFOT = 1
+ CALL ZGELQ( -1, 0, A, 1, TAU, 1, W, 1, INFO )
+ CALL CHKXER( 'ZGELQ', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL ZGELQ( 0, -1, A, 1, TAU, 1, W, 1, INFO )
+ CALL CHKXER( 'ZGELQ', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL ZGELQ( 1, 1, A, 0, TAU, 1, W, 1, INFO )
+ CALL CHKXER( 'ZGELQ', INFOT, NOUT, LERR, OK )
+ INFOT = 6
+ CALL ZGELQ( 2, 3, A, 3, TAU, 1, W, 1, INFO )
+ CALL CHKXER( 'ZGELQ', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL ZGELQ( 2, 3, A, 3, TAU, 8, W, 0, INFO )
+ CALL CHKXER( 'ZGELQ', INFOT, NOUT, LERR, OK )
+*
+* ZGEMLQ
+*
+ TAU(1)=1
+ TAU(2)=1
+ SRNAMT = 'ZGEMLQ'
+ NB=1
+ INFOT = 1
+ CALL ZGEMLQ( '/', 'N', 0, 0, 0, A, 1, TAU, 1, C, 1, W, 1,INFO)
+ CALL CHKXER( 'ZGEMLQ', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL ZGEMLQ( 'L', '/', 0, 0, 0, A, 1, TAU, 1, C, 1, W, 1,INFO)
+ CALL CHKXER( 'ZGEMLQ', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL ZGEMLQ( 'L', 'N', -1, 0, 0, A, 1, TAU, 1, C, 1, W,1,INFO)
+ CALL CHKXER( 'ZGEMLQ', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL ZGEMLQ( 'L', 'N', 0, -1, 0, A, 1, TAU, 1, C, 1, W,1,INFO)
+ CALL CHKXER( 'ZGEMLQ', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL ZGEMLQ( 'L', 'N', 0, 0, -1, A, 1, TAU, 1, C, 1, W,1,INFO)
+ CALL CHKXER( 'ZGEMLQ', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL ZGEMLQ( 'R', 'N', 0, 0, -1, A, 1, TAU, 1, C, 1, W,1,INFO)
+ CALL CHKXER( 'ZGEMLQ', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL ZGEMLQ( 'L', 'N', 1, 2, 0, A, 0, TAU, 1, C, 1, W, 1,INFO)
+ CALL CHKXER( 'ZGEMLQ', INFOT, NOUT, LERR, OK )
+ INFOT = 9
+ CALL ZGEMLQ( 'R', 'N', 2, 2, 1, A, 1, TAU, 0, C, 1, W, 1,INFO)
+ CALL CHKXER( 'ZGEMLQ', INFOT, NOUT, LERR, OK )
+ INFOT = 9
+ CALL ZGEMLQ( 'L', 'N', 2, 2, 1, A, 1, TAU, 0, C, 1, W, 1,INFO)
+ CALL CHKXER( 'ZGEMLQ', INFOT, NOUT, LERR, OK )
+ INFOT = 11
+ CALL ZGEMLQ( 'L', 'N', 1, 2, 1, A, 1, TAU, 6, C, 0, W, 1,INFO)
+ CALL CHKXER( 'ZGEMLQ', INFOT, NOUT, LERR, OK )
+ INFOT = 13
+ CALL ZGEMLQ( 'L', 'N', 2, 2, 1, A, 2, TAU, 6, C, 2, W, 0,INFO)
+ CALL CHKXER( 'ZGEMLQ', INFOT, NOUT, LERR, OK )
+*
+* Print a summary line.
+*
+ CALL ALAESM( PATH, OK, NOUT )
+*
+ RETURN
+*
+* End of DERRTSQR
+*
+ END
--- /dev/null
+*> \brief \b DLQT04
+*
+* =========== DOCUMENTATION ===========
+*
+* 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:
+* =============
+*>
+*> \verbatim
+*>
+*> ZLQT04 tests ZGELQT and ZUNMLQT.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> Number of rows in test matrix.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> Number of columns in test matrix.
+*> \endverbatim
+*>
+*> \param[in] NB
+*> \verbatim
+*> NB is INTEGER
+*> Block size of test matrix. NB <= Min(M,N).
+*> \endverbatim
+*>
+*> \param[out] RESULT
+*> \verbatim
+*> RESULT is DOUBLE PRECISION array, dimension (6)
+*> Results of each of the six tests below.
+*>
+*> RESULT(1) = | A - L Q |
+*> 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(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.
+*
+*> \date April 2012
+*
+*> \ingroup double_lin
+*
+* =====================================================================
+ SUBROUTINE ZLQT04(M,N,NB,RESULT)
+ IMPLICIT NONE
+*
+* -- LAPACK test routine (version 3.4.1) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* April 2012
+*
+* .. Scalar Arguments ..
+ INTEGER M, N, NB
+* .. Return values ..
+ DOUBLE PRECISION RESULT(6)
+*
+* =====================================================================
+*
+* ..
+* .. Local allocatable arrays
+ COMPLEX*16, ALLOCATABLE :: AF(:,:), Q(:,:),
+ $ L(:,:), RWORK(:), WORK( : ), T(:,:),
+ $ CF(:,:), DF(:,:), A(:,:), C(:,:), D(:,:)
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO
+ COMPLEX*16 ONE, CZERO
+ PARAMETER( ZERO = 0.0)
+ PARAMETER( ONE = (1.0,0.0), CZERO=(0.0,0.0) )
+* ..
+* .. Local Scalars ..
+ INTEGER INFO, J, K, LL, LWORK, LDT
+ DOUBLE PRECISION ANORM, EPS, RESID, CNORM, DNORM
+* ..
+* .. Local Arrays ..
+ INTEGER ISEED( 4 )
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMCH
+ DOUBLE PRECISION ZLANGE, ZLANSY
+ LOGICAL LSAME
+ EXTERNAL DLAMCH, ZLANGE, ZLANSY, LSAME
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Data statements ..
+ DATA ISEED / 1988, 1989, 1990, 1991 /
+*
+ EPS = DLAMCH( 'Epsilon' )
+ K = MIN(M,N)
+ LL = MAX(M,N)
+ LWORK = MAX(2,LL)*MAX(2,LL)*NB
+*
+* 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),
+ $ D(N,M), DF(N,M) )
+*
+* Put random numbers into A and copy to AF
+*
+ LDT=NB
+ DO J=1,N
+ CALL ZLARNV( 2, ISEED, M, A( 1, J ) )
+ END DO
+ CALL ZLACPY( 'Full', M, N, A, M, AF, M )
+*
+* Factor the matrix A in the array AF.
+*
+ CALL ZGELQT( M, N, NB, AF, M, T, LDT, WORK, INFO )
+*
+* 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,
+ $ WORK, INFO )
+*
+* Copy L
+*
+ CALL ZLASET( 'Full', LL, N, CZERO, CZERO, L, LL )
+ CALL ZLACPY( 'Lower', M, N, AF, M, L, LL )
+*
+* Compute |L - A*Q'| / |A| and store in RESULT(1)
+*
+ CALL ZGEMM( 'N', 'C', M, N, N, -ONE, A, M, Q, N, ONE, L, LL )
+ ANORM = ZLANGE( '1', M, N, A, M, RWORK )
+ RESID = ZLANGE( '1', M, N, L, LL, RWORK )
+ IF( ANORM.GT.ZERO ) THEN
+ RESULT( 1 ) = RESID / (EPS*MAX(1,M)*ANORM)
+ ELSE
+ RESULT( 1 ) = ZERO
+ END IF
+*
+* Compute |I - Q'*Q| and store in RESULT(2)
+*
+ CALL ZLASET( 'Full', N, N, CZERO, ONE, L, LL )
+ CALL ZHERK( 'U', 'C', N, N, DREAL(-ONE), Q, N, DREAL(ONE), L, LL)
+ RESID = ZLANSY( '1', 'Upper', N, L, LL, RWORK )
+ RESULT( 2 ) = RESID / (EPS*MAX(1,N))
+*
+* Generate random m-by-n matrix C and a copy CF
+*
+ DO J=1,M
+ CALL ZLARNV( 2, ISEED, N, D( 1, J ) )
+ END DO
+ DNORM = ZLANGE( '1', N, M, D, N, RWORK)
+ CALL ZLACPY( 'Full', N, M, D, N, DF, N )
+*
+* Apply Q to C as Q*C
+*
+ CALL ZGEMLQT( 'L', 'N', N, M, K, NB, AF, M, T, NB, DF, N,
+ $ WORK, INFO)
+*
+* Compute |Q*D - Q*D| / |D|
+*
+ CALL ZGEMM( 'N', 'N', N, M, N, -ONE, Q, N, D, N, ONE, DF, N )
+ RESID = ZLANGE( '1', N, M, DF, N, RWORK )
+ IF( DNORM.GT.ZERO ) THEN
+ RESULT( 3 ) = RESID / (EPS*MAX(1,M)*DNORM)
+ ELSE
+ RESULT( 3 ) = ZERO
+ END IF
+*
+* Copy D into DF again
+*
+ CALL ZLACPY( 'Full', N, M, D, N, DF, N )
+*
+* Apply Q to D as QT*D
+*
+ CALL ZGEMLQT( 'L', 'C', N, M, K, NB, AF, M, T, NB, DF, N,
+ $ WORK, INFO)
+*
+* Compute |QT*D - QT*D| / |D|
+*
+ CALL ZGEMM( 'C', 'N', N, M, N, -ONE, Q, N, D, N, ONE, DF, N )
+ RESID = ZLANGE( '1', N, M, DF, N, RWORK )
+ IF( DNORM.GT.ZERO ) THEN
+ RESULT( 4 ) = RESID / (EPS*MAX(1,M)*DNORM)
+ ELSE
+ RESULT( 4 ) = ZERO
+ END IF
+*
+* Generate random n-by-m matrix D and a copy DF
+*
+ DO J=1,N
+ CALL ZLARNV( 2, ISEED, M, C( 1, J ) )
+ END DO
+ CNORM = ZLANGE( '1', M, N, C, M, RWORK)
+ CALL ZLACPY( 'Full', M, N, C, M, CF, M )
+*
+* Apply Q to C as C*Q
+*
+ CALL ZGEMLQT( 'R', 'N', M, N, K, NB, AF, M, T, NB, CF, M,
+ $ WORK, INFO)
+*
+* Compute |C*Q - C*Q| / |C|
+*
+ CALL ZGEMM( 'N', 'N', M, N, N, -ONE, C, M, Q, N, ONE, CF, M )
+ RESID = ZLANGE( '1', N, M, DF, N, RWORK )
+ IF( CNORM.GT.ZERO ) THEN
+ RESULT( 5 ) = RESID / (EPS*MAX(1,M)*DNORM)
+ ELSE
+ RESULT( 5 ) = ZERO
+ END IF
+*
+* Copy C into CF again
+*
+ CALL ZLACPY( 'Full', M, N, C, M, CF, M )
+*
+* Apply Q to D as D*QT
+*
+ CALL ZGEMLQT( 'R', 'C', M, N, K, NB, AF, M, T, NB, CF, M,
+ $ WORK, INFO)
+*
+* Compute |C*QT - C*QT| / |C|
+*
+ CALL ZGEMM( 'N', 'C', M, N, N, -ONE, C, M, Q, N, ONE, CF, M )
+ RESID = ZLANGE( '1', M, N, CF, M, RWORK )
+ IF( CNORM.GT.ZERO ) THEN
+ RESULT( 6 ) = RESID / (EPS*MAX(1,M)*DNORM)
+ ELSE
+ RESULT( 6 ) = ZERO
+ END IF
+*
+* Deallocate all arrays
+*
+ DEALLOCATE ( A, AF, Q, L, RWORK, WORK, T, C, D, CF, DF)
+*
+ RETURN
+ END
+
--- /dev/null
+*> \brief \b ZLQT05
+*
+* =========== DOCUMENTATION ===========
+*
+* 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:
+* =============
+*>
+*> \verbatim
+*>
+*> ZQRT05 tests ZTPLQT and ZTPMLQT.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> Number of rows in lower part of the test matrix.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> Number of columns in test matrix.
+*> \endverbatim
+*>
+*> \param[in] L
+*> \verbatim
+*> L is INTEGER
+*> The number of rows of the upper trapezoidal part the
+*> lower test matrix. 0 <= L <= M.
+*> \endverbatim
+*>
+*> \param[in] NB
+*> \verbatim
+*> NB is INTEGER
+*> Block size of test matrix. NB <= N.
+*> \endverbatim
+*>
+*> \param[out] RESULT
+*> \verbatim
+*> RESULT is DOUBLE PRECISION array, dimension (6)
+*> Results of each of the six tests below.
+*>
+*> RESULT(1) = | A - Q R |
+*> 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(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.
+*
+*> \date April 2012
+*
+*> \ingroup double_lin
+*
+* =====================================================================
+ SUBROUTINE ZLQT05(M,N,L,NB,RESULT)
+ IMPLICIT NONE
+*
+* -- LAPACK test routine (version 3.4.1) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* April 2012
+*
+* .. Scalar Arguments ..
+ INTEGER LWORK, M, N, L, NB, LDT
+* .. Return values ..
+ DOUBLE PRECISION RESULT(6)
+*
+* =====================================================================
+*
+* ..
+* .. Local allocatable arrays
+ COMPLEX*16, ALLOCATABLE :: AF(:,:), Q(:,:),
+ $ R(:,:), RWORK(:), WORK( : ), T(:,:),
+ $ CF(:,:), DF(:,:), A(:,:), C(:,:), D(:,:)
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO
+ COMPLEX*16 ONE, CZERO
+ PARAMETER( ZERO = 0.0, ONE = (1.0,0.0), CZERO=(0.0,0.0) )
+* ..
+* .. Local Scalars ..
+ INTEGER INFO, J, K, N2, NP1,i
+ DOUBLE PRECISION ANORM, EPS, RESID, CNORM, DNORM
+* ..
+* .. Local Arrays ..
+ INTEGER ISEED( 4 )
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMCH
+ DOUBLE PRECISION ZLANGE, ZLANSY
+ LOGICAL LSAME
+ EXTERNAL DLAMCH, ZLANGE, ZLANSY, LSAME
+* ..
+* .. Data statements ..
+ DATA ISEED / 1988, 1989, 1990, 1991 /
+*
+ EPS = DLAMCH( 'Epsilon' )
+ K = M
+ N2 = M+N
+ IF( N.GT.0 ) THEN
+ NP1 = M+1
+ ELSE
+ NP1 = 1
+ END IF
+ LWORK = N2*N2*NB
+*
+* 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),
+ $ D(M,N2),DF(M,N2) )
+*
+* Put random stuff into A
+*
+ LDT=NB
+ CALL ZLASET( 'Full', M, N2, CZERO, CZERO, A, M )
+ CALL ZLASET( 'Full', NB, M, CZERO, CZERO, T, NB )
+ DO J=1,M
+ CALL ZLARNV( 2, ISEED, M-J+1, A( J, J ) )
+ END DO
+ IF( N.GT.0 ) THEN
+ DO J=1,N-L
+ CALL ZLARNV( 2, ISEED, M, A( 1, MIN(N+M,M+1) + J - 1 ) )
+ END DO
+ 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)
+ $ + J - 1 ) )
+ END DO
+ END IF
+*
+* Copy the matrix A to the array AF.
+*
+ CALL ZLACPY( 'Full', M, N2, A, M, AF, M )
+*
+* Factor the matrix A in the array AF.
+*
+ CALL ZTPLQT( M,N,L,NB,AF,M,AF(1,NP1),M,T,LDT,WORK,INFO)
+*
+* Generate the (M+N)-by-(M+N) matrix Q by applying H to I
+*
+ CALL ZLASET( 'Full', N2, N2, CZERO, ONE, Q, N2 )
+ CALL ZGEMLQT( 'L', 'N', N2, N2, K, NB, AF, M, T, LDT, Q, N2,
+ $ WORK, INFO )
+*
+* Copy L
+*
+ CALL ZLASET( 'Full', N2, N2, CZERO, CZERO, R, N2 )
+ CALL ZLACPY( 'Lower', M, N2, AF, M, R, N2 )
+*
+* Compute |L - A*Q*C| / |A| and store in RESULT(1)
+*
+ CALL ZGEMM( 'N', 'C', M, N2, N2, -ONE, A, M, Q, N2, ONE, R, N2)
+ ANORM = ZLANGE( '1', M, N2, A, M, RWORK )
+ RESID = ZLANGE( '1', M, N2, R, N2, RWORK )
+ IF( ANORM.GT.ZERO ) THEN
+ RESULT( 1 ) = RESID / (EPS*ANORM*MAX(1,N2))
+ ELSE
+ RESULT( 1 ) = ZERO
+ END IF
+*
+* Compute |I - Q*Q'| and store in RESULT(2)
+*
+ CALL ZLASET( 'Full', N2, N2, CZERO, ONE, R, N2 )
+ CALL ZHERK( 'U', 'N', N2, N2, DREAL(-ONE), Q, N2, DREAL(ONE),
+ $ R, N2 )
+ RESID = ZLANSY( '1', 'Upper', N2, R, N2, RWORK )
+ RESULT( 2 ) = RESID / (EPS*MAX(1,N2))
+*
+* Generate random m-by-n matrix C and a copy CF
+*
+ CALL ZLASET( 'Full', N2, M, CZERO, ONE, C, N2 )
+ DO J=1,M
+ CALL ZLARNV( 2, ISEED, N2, C( 1, J ) )
+ END DO
+ CNORM = ZLANGE( '1', N2, M, C, N2, RWORK)
+ 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)
+*
+* Compute |Q*C - Q*C| / |C|
+*
+ CALL ZGEMM( 'N', '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( 3 ) = RESID / (EPS*MAX(1,N2)*CNORM)
+ ELSE
+ RESULT( 3 ) = ZERO
+ END IF
+
+*
+* Copy C into CF again
+*
+ CALL ZLACPY( 'Full', N2, M, C, N2, CF, N2 )
+*
+* 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)
+*
+* 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
+*
+* Generate random m-by-n matrix D and a copy DF
+*
+ DO J=1,N2
+ CALL ZLARNV( 2, ISEED, M, D( 1, J ) )
+ END DO
+ DNORM = ZLANGE( '1', M, N2, D, M, RWORK)
+ CALL ZLACPY( 'Full', M, N2, D, M, DF, M )
+*
+* Apply Q to D as D*Q
+*
+ CALL ZTPMLQT('R','N',M,N,K,L,NB,AF(1,NP1),M,T,LDT,DF,M,
+ $ DF(1,NP1),M,WORK,INFO)
+*
+* Compute |D*Q - D*Q| / |D|
+*
+ CALL ZGEMM('N','N',M,N2,N2,-ONE,D,M,Q,N2,ONE,DF,M)
+ RESID = ZLANGE('1',M, N2,DF,M,RWORK )
+ IF( CNORM.GT.ZERO ) THEN
+ RESULT( 5 ) = RESID / (EPS*MAX(1,N2)*DNORM)
+ ELSE
+ RESULT( 5 ) = ZERO
+ END IF
+*
+* Copy D into DF again
+*
+ CALL ZLACPY('Full',M,N2,D,M,DF,M )
+*
+* 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)
+
+*
+* Compute |D*QT - D*QT| / |D|
+*
+ CALL ZGEMM( 'N', 'C', M, N2, N2, -ONE, D, M, Q, N2, ONE, DF, M )
+ RESID = ZLANGE( '1', M, N2, DF, M, RWORK )
+ IF( CNORM.GT.ZERO ) THEN
+ RESULT( 6 ) = RESID / (EPS*MAX(1,N2)*DNORM)
+ ELSE
+ RESULT( 6 ) = ZERO
+ END IF
+*
+* Deallocate all arrays
+*
+ DEALLOCATE ( A, AF, Q, R, RWORK, WORK, T, C, D, CF, DF)
+ RETURN
+ END
\ No newline at end of file
--- /dev/null
+*> \brief \b ZTSQR01
+*
+* =========== DOCUMENTATION ===========
+*
+* 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:
+* =============
+*>
+*> \verbatim
+*>
+*> ZTSQR01 tests ZGEQR , ZGELQ, ZGEMLQ and ZGEMQR.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] TSSW
+*> \verbatim
+*> TSSW is CHARACTER
+*> 'TS' for testing tall skinny QR
+*> and anything else for testing short wide LQ
+*> \endverbatim
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> Number of rows in test matrix.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> Number of columns in test matrix.
+*> \endverbatim
+*> \param[in] MB
+*> \verbatim
+*> MB is INTEGER
+*> Number of row in row block in test matrix.
+*> \endverbatim
+*>
+*> \param[in] NB
+*> \verbatim
+*> NB is INTEGER
+*> Number of columns in column block test matrix.
+*> \endverbatim
+*>
+*> \param[out] RESULT
+*> \verbatim
+*> RESULT is DOUBLE PRECISION array, dimension (6)
+*> Results of each of the six tests below.
+*>
+*> RESULT(1) = | A - Q R | or | A - L Q |
+*> 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(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.
+*
+*> \date April 2012
+*
+* =====================================================================
+ SUBROUTINE ZTSQR01(TSSW, M, N, MB, NB, RESULT)
+ IMPLICIT NONE
+*
+* -- LAPACK test routine (version 3.4.1) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* April 2012
+*
+* .. Scalar Arguments ..
+ CHARACTER TSSW
+ INTEGER M, N, MB, NB
+* .. Return values ..
+ DOUBLE PRECISION RESULT(6)
+*
+* =====================================================================
+*
+* ..
+* .. Local allocatable arrays
+ COMPLEX*16, ALLOCATABLE :: AF(:,:), Q(:,:),
+ $ R(:,:), RWORK(:), WORK( : ), T(:),
+ $ CF(:,:), DF(:,:), A(:,:), C(:,:), D(:,:), LQ(:,:)
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO
+ COMPLEX*16 ONE, CZERO
+ PARAMETER( ZERO = 0.0, ONE = (1.0,0.0), CZERO=(0.0,0.0) )
+* ..
+* .. Local Scalars ..
+ LOGICAL TESTZEROS, TS
+ INTEGER INFO, J, K, L, LWORK, LT ,MNB
+ DOUBLE PRECISION ANORM, EPS, RESID, CNORM, DNORM
+* ..
+* .. Local Arrays ..
+ INTEGER ISEED( 4 )
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMCH, ZLANGE, ZLANSY
+ LOGICAL LSAME
+ INTEGER ILAENV
+ EXTERNAL DLAMCH, ZLANGE, ZLANSY, LSAME, ILAENV
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* .. Scalars in Common ..
+ CHARACTER*32 srnamt
+* ..
+* .. Common blocks ..
+ COMMON / srnamc / srnamt
+* ..
+* .. Data statements ..
+ 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)
+ MNB = MAX ( MB, NB)
+ LWORK = MAX(3,L)*MNB
+ 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
+ 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),
+ $ D(N,M), DF(N,M), LQ(L,N) )
+*
+* Put random numbers into A and copy to AF
+*
+ DO J=1,N
+ CALL ZLARNV( 2, ISEED, M, A( 1, J ) )
+ END DO
+ IF (TESTZEROS) THEN
+ IF (M.GE.4) THEN
+ DO J=1,N
+ CALL ZLARNV( 2, ISEED, M/2, A( M/4, J ) )
+ END DO
+ END IF
+ END IF
+ CALL ZLACPY( 'Full', M, N, A, M, AF, M )
+*
+ IF (TS) THEN
+*
+* Factor the matrix A in the array AF.
+*
+ srnamt = 'ZGEQR'
+ CALL ZGEQR( M, N, AF, M, T, LT, WORK, LWORK, INFO )
+*
+* Generate the m-by-m matrix Q
+*
+ CALL ZLASET( 'Full', M, M, CZERO, ONE, Q, M )
+ srnamt = 'ZGEMQR'
+ CALL ZGEMQR( 'L', 'N', M, M, K, AF, M, T, LT, Q, M,
+ $ WORK, LWORK, INFO )
+*
+* Copy R
+*
+ CALL ZLASET( 'Full', M, N, CZERO, CZERO, R, M )
+ CALL ZLACPY( 'Upper', M, N, AF, M, R, M )
+*
+* Compute |R - Q'*A| / |A| and store in RESULT(1)
+*
+ CALL ZGEMM( 'C', 'N', M, N, M, -ONE, Q, M, A, M, ONE, R, M )
+ ANORM = ZLANGE( '1', M, N, A, M, RWORK )
+ RESID = ZLANGE( '1', M, N, R, M, RWORK )
+ IF( ANORM.GT.ZERO ) THEN
+ RESULT( 1 ) = RESID / (EPS*MAX(1,M)*ANORM)
+ ELSE
+ RESULT( 1 ) = ZERO
+ END IF
+*
+* Compute |I - Q'*Q| and store in RESULT(2)
+*
+ CALL ZLASET( 'Full', M, M, CZERO, ONE, R, M )
+ CALL ZHERK( 'U', 'C', M, M, DREAL(-ONE), Q, M, DREAL(ONE), R, M )
+ RESID = ZLANSY( '1', 'Upper', M, R, M, RWORK )
+ RESULT( 2 ) = RESID / (EPS*MAX(1,M))
+*
+* Generate random m-by-n matrix C and a copy CF
+*
+ DO J=1,N
+ CALL ZLARNV( 2, ISEED, M, C( 1, J ) )
+ END DO
+ CNORM = ZLANGE( '1', M, N, C, M, RWORK)
+ CALL ZLACPY( 'Full', M, N, C, M, CF, M )
+*
+* Apply Q to C as Q*C
+*
+ srnamt = 'ZGEMQR'
+ CALL ZGEMQR( 'L', 'N', M, N, K, AF, M, T, LT, CF, M,
+ $ WORK, LWORK, INFO)
+*
+* Compute |Q*C - Q*C| / |C|
+*
+ CALL ZGEMM( 'N', 'N', M, N, M, -ONE, Q, M, C, M, ONE, CF, M )
+ RESID = ZLANGE( '1', M, N, CF, M, RWORK )
+ IF( CNORM.GT.ZERO ) THEN
+ RESULT( 3 ) = RESID / (EPS*MAX(1,M)*CNORM)
+ ELSE
+ RESULT( 3 ) = ZERO
+ END IF
+*
+* Copy C into CF again
+*
+ CALL ZLACPY( 'Full', M, N, C, M, CF, M )
+*
+* Apply Q to C as QT*C
+*
+ srnamt = 'ZGEMQR'
+ CALL ZGEMQR( 'L', 'C', M, N, K, AF, M, T, LT, CF, M,
+ $ WORK, LWORK, INFO)
+*
+* Compute |QT*C - QT*C| / |C|
+*
+ CALL ZGEMM( 'C', 'N', M, N, M, -ONE, Q, M, C, M, ONE, CF, M )
+ RESID = ZLANGE( '1', M, N, CF, M, RWORK )
+ IF( CNORM.GT.ZERO ) THEN
+ RESULT( 4 ) = RESID / (EPS*MAX(1,M)*CNORM)
+ ELSE
+ RESULT( 4 ) = ZERO
+ END IF
+*
+* Generate random n-by-m matrix D and a copy DF
+*
+ DO J=1,M
+ CALL ZLARNV( 2, ISEED, N, D( 1, J ) )
+ END DO
+ DNORM = ZLANGE( '1', N, M, D, N, RWORK)
+ CALL ZLACPY( 'Full', N, M, D, N, DF, N )
+*
+* 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)
+*
+* Compute |D*Q - D*Q| / |D|
+*
+ CALL ZGEMM( 'N', 'N', N, M, M, -ONE, D, N, Q, M, ONE, DF, N )
+ RESID = ZLANGE( '1', N, M, DF, N, RWORK )
+ IF( DNORM.GT.ZERO ) THEN
+ RESULT( 5 ) = RESID / (EPS*MAX(1,M)*DNORM)
+ ELSE
+ RESULT( 5 ) = ZERO
+ END IF
+*
+* Copy D into DF again
+*
+ CALL ZLACPY( 'Full', N, M, D, N, DF, N )
+*
+* Apply Q to D as D*QT
+*
+ CALL ZGEMQR( 'R', 'C', N, M, K, AF, M, T, LT, DF, N,
+ $ WORK, LWORK, INFO)
+*
+* Compute |D*QT - D*QT| / |D|
+*
+ CALL ZGEMM( 'N', 'C', N, M, M, -ONE, D, N, Q, M, ONE, DF, N )
+ RESID = ZLANGE( '1', N, M, DF, N, RWORK )
+ IF( CNORM.GT.ZERO ) THEN
+ RESULT( 6 ) = RESID / (EPS*MAX(1,M)*DNORM)
+ ELSE
+ RESULT( 6 ) = ZERO
+ END IF
+*
+* Short and wide
+*
+ ELSE
+ srnamt = 'ZGELQ'
+ CALL ZGELQ( M, N, AF, M, T, LT, WORK, LWORK, INFO )
+*
+*
+* Generate the n-by-n matrix Q
+*
+ CALL ZLASET( 'Full', N, N, CZERO, ONE, Q, N )
+ srnamt = 'ZGEMLQ'
+ CALL ZGEMLQ( 'R', 'N', N, N, K, AF, M, T, LT, Q, N,
+ $ WORK, LWORK, INFO )
+*
+* Copy R
+*
+ CALL ZLASET( 'Full', M, N, CZERO, CZERO, LQ, L )
+ CALL ZLACPY( 'Lower', M, N, AF, M, LQ, L )
+*
+* Compute |L - A*Q'| / |A| and store in RESULT(1)
+*
+ CALL ZGEMM( 'N', 'C', M, N, N, -ONE, A, M, Q, N, ONE, LQ, L )
+ ANORM = ZLANGE( '1', M, N, A, M, RWORK )
+ RESID = ZLANGE( '1', M, N, LQ, L, RWORK )
+ IF( ANORM.GT.ZERO ) THEN
+ RESULT( 1 ) = RESID / (EPS*MAX(1,N)*ANORM)
+ ELSE
+ RESULT( 1 ) = ZERO
+ END IF
+*
+* Compute |I - Q'*Q| and store in RESULT(2)
+*
+ CALL ZLASET( 'Full', N, N, CZERO, ONE, LQ, L )
+ CALL ZHERK( 'U', 'C', N, N, DREAL(-ONE), Q, N, DREAL(ONE), LQ, L)
+ RESID = ZLANSY( '1', 'Upper', N, LQ, L, RWORK )
+ RESULT( 2 ) = RESID / (EPS*MAX(1,N))
+*
+* Generate random m-by-n matrix C and a copy CF
+*
+ DO J=1,M
+ CALL ZLARNV( 2, ISEED, N, D( 1, J ) )
+ END DO
+ DNORM = ZLANGE( '1', N, M, D, N, RWORK)
+ CALL ZLACPY( 'Full', N, M, D, N, DF, N )
+*
+* Apply Q to C as Q*C
+*
+ CALL ZGEMLQ( 'L', 'N', N, M, K, AF, M, T, LT, DF, N,
+ $ WORK, LWORK, INFO)
+*
+* Compute |Q*D - Q*D| / |D|
+*
+ CALL ZGEMM( 'N', 'N', N, M, N, -ONE, Q, N, D, N, ONE, DF, N )
+ RESID = ZLANGE( '1', N, M, DF, N, RWORK )
+ IF( DNORM.GT.ZERO ) THEN
+ RESULT( 3 ) = RESID / (EPS*MAX(1,N)*DNORM)
+ ELSE
+ RESULT( 3 ) = ZERO
+ END IF
+*
+* Copy D into DF again
+*
+ CALL ZLACPY( 'Full', N, M, D, N, DF, N )
+*
+* Apply Q to D as QT*D
+*
+ CALL ZGEMLQ( 'L', 'C', N, M, K, AF, M, T, LT, DF, N,
+ $ WORK, LWORK, INFO)
+*
+* Compute |QT*D - QT*D| / |D|
+*
+ CALL ZGEMM( 'C', 'N', N, M, N, -ONE, Q, N, D, N, ONE, DF, N )
+ RESID = ZLANGE( '1', N, M, DF, N, RWORK )
+ IF( DNORM.GT.ZERO ) THEN
+ RESULT( 4 ) = RESID / (EPS*MAX(1,N)*DNORM)
+ ELSE
+ RESULT( 4 ) = ZERO
+ END IF
+*
+* Generate random n-by-m matrix D and a copy DF
+*
+ DO J=1,N
+ CALL ZLARNV( 2, ISEED, M, C( 1, J ) )
+ END DO
+ CNORM = ZLANGE( '1', M, N, C, M, RWORK)
+ CALL ZLACPY( 'Full', M, N, C, M, CF, M )
+*
+* Apply Q to C as C*Q
+*
+ CALL ZGEMLQ( 'R', 'N', M, N, K, AF, M, T, LT, CF, M,
+ $ WORK, LWORK, INFO)
+*
+* Compute |C*Q - C*Q| / |C|
+*
+ CALL ZGEMM( 'N', 'N', M, N, N, -ONE, C, M, Q, N, ONE, CF, M )
+ RESID = ZLANGE( '1', N, M, DF, N, RWORK )
+ IF( CNORM.GT.ZERO ) THEN
+ RESULT( 5 ) = RESID / (EPS*MAX(1,N)*CNORM)
+ ELSE
+ RESULT( 5 ) = ZERO
+ END IF
+*
+* Copy C into CF again
+*
+ CALL ZLACPY( 'Full', M, N, C, M, CF, M )
+*
+* Apply Q to D as D*QT
+*
+ CALL ZGEMLQ( 'R', 'C', M, N, K, AF, M, T, LT, CF, M,
+ $ WORK, LWORK, INFO)
+*
+* Compute |C*QT - C*QT| / |C|
+*
+ CALL ZGEMM( 'N', 'C', M, N, N, -ONE, C, M, Q, N, ONE, CF, M )
+ RESID = ZLANGE( '1', M, N, CF, M, RWORK )
+ IF( CNORM.GT.ZERO ) THEN
+ RESULT( 6 ) = RESID / (EPS*MAX(1,N)*CNORM)
+ ELSE
+ RESULT( 6 ) = ZERO
+ END IF
+*
+ END IF
+*
+* Deallocate all arrays
+*
+ DEALLOCATE ( A, AF, Q, R, RWORK, WORK, T, C, D, CF, DF)
+*
+ RETURN
+ END
\ No newline at end of file
CEQ
CQT
CQX
+CXQ
+CTQ
+CTS
DEQ
DQT
DQX
+DXQ
+DTQ
+DTS
\ No newline at end of file
SEQ
SQT
SQX
+SXQ
+STQ
+STS
ZEQ
ZQT
ZQX
+ZXQ
+ZTQ
+ZTS
+++ /dev/null
-Subproject commit 44f54c02c6242ece672619df26752d27ab5a07c0
projects / platform / upstream / lapack.git / commitdiff