diff options
119 files changed, 29031 insertions, 374 deletions
| Binary files differ diff --git a/SRC/Makefile b/SRC/Makefile index b8d43234..8662b539 100644 --- a/SRC/Makefile +++ b/SRC/Makefile @@ -26,7 +26,7 @@ include ../make.inc # precision. # ZLASRC -- Double precision complex LAPACK routines # ZXLASRC -- Double precision complex LAPACK routines using extra -# precision. +# precision. # # DEPRECATED -- Deprecated routines in all precisions # @@ -145,7 +145,6 @@ SLASRC = \ 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 \ @@ -160,9 +159,13 @@ SLASRC = \ 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 \ @@ -197,7 +200,6 @@ CLASRC = \ 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 \ @@ -245,7 +247,11 @@ CLASRC = \ 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 \ @@ -261,7 +267,7 @@ 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 \ @@ -314,7 +320,6 @@ DLASRC = \ 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 \ @@ -329,7 +334,11 @@ DLASRC = \ 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 \ @@ -365,7 +374,6 @@ ZLASRC = \ 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 \ @@ -418,7 +426,12 @@ ZLASRC = \ 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 \ @@ -504,7 +517,7 @@ FRC: clean: rm -f *.o DEPRECATED/*.o -.f.o: +.f.o: $(FORTRAN) $(OPTS) -c $< -o $@ slaruv.o: slaruv.f ; $(FORTRAN) $(NOOPT) -c $< -o $@ diff --git a/SRC/cgelq.f b/SRC/cgelq.f new file mode 100644 index 00000000..e6e2b129 --- /dev/null +++ b/SRC/cgelq.f @@ -0,0 +1,267 @@ +* +* 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 diff --git a/SRC/cgelqt.f b/SRC/cgelqt.f new file mode 100644 index 00000000..70abe1af --- /dev/null +++ b/SRC/cgelqt.f @@ -0,0 +1,194 @@ +* +* 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 diff --git a/SRC/cgelqt3.f b/SRC/cgelqt3.f new file mode 100644 index 00000000..98dbfc63 --- /dev/null +++ b/SRC/cgelqt3.f @@ -0,0 +1,244 @@ +* 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 diff --git a/SRC/cgemlq.f b/SRC/cgemlq.f new file mode 100644 index 00000000..bd7823df --- /dev/null +++ b/SRC/cgemlq.f @@ -0,0 +1,261 @@ +* +* 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 diff --git a/SRC/cgemlqt.f b/SRC/cgemlqt.f new file mode 100644 index 00000000..04f44e41 --- /dev/null +++ b/SRC/cgemlqt.f @@ -0,0 +1,272 @@ +* 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 diff --git a/SRC/cgemqr.f b/SRC/cgemqr.f new file mode 100644 index 00000000..de2965ee --- /dev/null +++ b/SRC/cgemqr.f @@ -0,0 +1,268 @@ +* +* 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 diff --git a/SRC/cgeqr.f b/SRC/cgeqr.f new file mode 100644 index 00000000..c5151408 --- /dev/null +++ b/SRC/cgeqr.f @@ -0,0 +1,268 @@ +* +* 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 diff --git a/SRC/cgetsls.f b/SRC/cgetsls.f new file mode 100644 index 00000000..438aced8 --- /dev/null +++ b/SRC/cgetsls.f @@ -0,0 +1,490 @@ +* 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 diff --git a/SRC/clamswlq.f b/SRC/clamswlq.f new file mode 100644 index 00000000..3b640b84 --- /dev/null +++ b/SRC/clamswlq.f @@ -0,0 +1,405 @@ +* +* 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 diff --git a/SRC/clamtsqr.f b/SRC/clamtsqr.f new file mode 100644 index 00000000..0f9ac57b --- /dev/null +++ b/SRC/clamtsqr.f @@ -0,0 +1,409 @@ +* +* 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 diff --git a/SRC/claswlq.f b/SRC/claswlq.f new file mode 100644 index 00000000..91db14c9 --- /dev/null +++ b/SRC/claswlq.f @@ -0,0 +1,262 @@ +* +* 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 diff --git a/SRC/clatsqr.f b/SRC/clatsqr.f new file mode 100644 index 00000000..e462ab77 --- /dev/null +++ b/SRC/clatsqr.f @@ -0,0 +1,255 @@ +* +* 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 diff --git a/SRC/ctplqt.f b/SRC/ctplqt.f new file mode 100644 index 00000000..4de86153 --- /dev/null +++ b/SRC/ctplqt.f @@ -0,0 +1,253 @@ +* 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 diff --git a/SRC/ctplqt2.f b/SRC/ctplqt2.f new file mode 100644 index 00000000..74979369 --- /dev/null +++ b/SRC/ctplqt2.f @@ -0,0 +1,316 @@ +* 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 diff --git a/SRC/ctpmlqt.f b/SRC/ctpmlqt.f new file mode 100644 index 00000000..411ef72d --- /dev/null +++ b/SRC/ctpmlqt.f @@ -0,0 +1,349 @@ +* 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 diff --git a/SRC/dgelq.f b/SRC/dgelq.f new file mode 100644 index 00000000..4086cd36 --- /dev/null +++ b/SRC/dgelq.f @@ -0,0 +1,269 @@ +* +* 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 diff --git a/SRC/dgelqt.f b/SRC/dgelqt.f new file mode 100644 index 00000000..0f301699 --- /dev/null +++ b/SRC/dgelqt.f @@ -0,0 +1,210 @@ +*> \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 diff --git a/SRC/dgelqt3.f b/SRC/dgelqt3.f new file mode 100644 index 00000000..11c040c2 --- /dev/null +++ b/SRC/dgelqt3.f @@ -0,0 +1,259 @@ +*> \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 diff --git a/SRC/dgemlq.f b/SRC/dgemlq.f new file mode 100644 index 00000000..8cf911b3 --- /dev/null +++ b/SRC/dgemlq.f @@ -0,0 +1,262 @@ +* +* 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 diff --git a/SRC/dgemlqt.f b/SRC/dgemlqt.f new file mode 100644 index 00000000..ebf3e476 --- /dev/null +++ b/SRC/dgemlqt.f @@ -0,0 +1,289 @@ +*> \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 diff --git a/SRC/dgemqr.f b/SRC/dgemqr.f new file mode 100644 index 00000000..73c84bf6 --- /dev/null +++ b/SRC/dgemqr.f @@ -0,0 +1,272 @@ +* +* 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 diff --git a/SRC/dgeqr.f b/SRC/dgeqr.f new file mode 100644 index 00000000..e0c6d75b --- /dev/null +++ b/SRC/dgeqr.f @@ -0,0 +1,267 @@ +* +* 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 diff --git a/SRC/dgetsls.f b/SRC/dgetsls.f new file mode 100644 index 00000000..cda63bd1 --- /dev/null +++ b/SRC/dgetsls.f @@ -0,0 +1,475 @@ +* 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 diff --git a/SRC/dlamswlq.f b/SRC/dlamswlq.f new file mode 100644 index 00000000..6230e65f --- /dev/null +++ b/SRC/dlamswlq.f @@ -0,0 +1,406 @@ +* +* 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 diff --git a/SRC/dlamtsqr.f b/SRC/dlamtsqr.f new file mode 100644 index 00000000..2cb9f96a --- /dev/null +++ b/SRC/dlamtsqr.f @@ -0,0 +1,404 @@ +* +* 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 diff --git a/SRC/dlaswlq.f b/SRC/dlaswlq.f new file mode 100644 index 00000000..e9be802c --- /dev/null +++ b/SRC/dlaswlq.f @@ -0,0 +1,258 @@ +* +* 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 diff --git a/SRC/dlatsqr.f b/SRC/dlatsqr.f new file mode 100644 index 00000000..4b9a787a --- /dev/null +++ b/SRC/dlatsqr.f @@ -0,0 +1,256 @@ +* +* 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 diff --git a/SRC/dtplqt.f b/SRC/dtplqt.f new file mode 100644 index 00000000..eea37b82 --- /dev/null +++ b/SRC/dtplqt.f @@ -0,0 +1,270 @@ +*> \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 diff --git a/SRC/dtplqt2.f b/SRC/dtplqt2.f new file mode 100644 index 00000000..9ed7c6ae --- /dev/null +++ b/SRC/dtplqt2.f @@ -0,0 +1,312 @@ +*> \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 diff --git a/SRC/dtpmlqt.f b/SRC/dtpmlqt.f new file mode 100644 index 00000000..d1193391 --- /dev/null +++ b/SRC/dtpmlqt.f @@ -0,0 +1,366 @@ +*> \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 diff --git a/SRC/ilaenv.f b/SRC/ilaenv.f index d8217a3c..e81446cb 100644 --- a/SRC/ilaenv.f +++ b/SRC/ilaenv.f @@ -2,29 +2,29 @@ * * =========== 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: * ============= @@ -127,14 +127,14 @@ * 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: * ===================== @@ -162,10 +162,10 @@ * ===================================================================== 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 @@ -283,6 +283,50 @@ 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 @@ -397,12 +441,6 @@ 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 diff --git a/SRC/sgelq.f b/SRC/sgelq.f new file mode 100644 index 00000000..4e5a3500 --- /dev/null +++ b/SRC/sgelq.f @@ -0,0 +1,269 @@ +* +* 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 diff --git a/SRC/sgelqt.f b/SRC/sgelqt.f new file mode 100644 index 00000000..6b037811 --- /dev/null +++ b/SRC/sgelqt.f @@ -0,0 +1,193 @@ +* 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 diff --git a/SRC/sgelqt3.f b/SRC/sgelqt3.f new file mode 100644 index 00000000..94784feb --- /dev/null +++ b/SRC/sgelqt3.f @@ -0,0 +1,242 @@ +* 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 diff --git a/SRC/sgemlq.f b/SRC/sgemlq.f new file mode 100644 index 00000000..37a9fb9b --- /dev/null +++ b/SRC/sgemlq.f @@ -0,0 +1,261 @@ +* +* 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 diff --git a/SRC/sgemlqt.f b/SRC/sgemlqt.f new file mode 100644 index 00000000..7e0dfff7 --- /dev/null +++ b/SRC/sgemlqt.f @@ -0,0 +1,272 @@ +* 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 diff --git a/SRC/sgemqr.f b/SRC/sgemqr.f new file mode 100644 index 00000000..8e3deacb --- /dev/null +++ b/SRC/sgemqr.f @@ -0,0 +1,269 @@ +* +* 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 diff --git a/SRC/sgeqr.f b/SRC/sgeqr.f new file mode 100644 index 00000000..c984404c --- /dev/null +++ b/SRC/sgeqr.f @@ -0,0 +1,267 @@ +* +* 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 diff --git a/SRC/sgetsls.f b/SRC/sgetsls.f new file mode 100644 index 00000000..73496a89 --- /dev/null +++ b/SRC/sgetsls.f @@ -0,0 +1,475 @@ +* 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 diff --git a/SRC/slamswlq.f b/SRC/slamswlq.f new file mode 100644 index 00000000..c636c70c --- /dev/null +++ b/SRC/slamswlq.f @@ -0,0 +1,406 @@ +* +* 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 diff --git a/SRC/slamtsqr.f b/SRC/slamtsqr.f new file mode 100644 index 00000000..3618db08 --- /dev/null +++ b/SRC/slamtsqr.f @@ -0,0 +1,405 @@ +* +* 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 diff --git a/SRC/slaswlq.f b/SRC/slaswlq.f new file mode 100644 index 00000000..acd9170d --- /dev/null +++ b/SRC/slaswlq.f @@ -0,0 +1,258 @@ +* +* 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 diff --git a/SRC/slatsqr.f b/SRC/slatsqr.f new file mode 100644 index 00000000..3fbf8b88 --- /dev/null +++ b/SRC/slatsqr.f @@ -0,0 +1,255 @@ +* +* 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 diff --git a/SRC/stplqt.f b/SRC/stplqt.f new file mode 100644 index 00000000..56d19d71 --- /dev/null +++ b/SRC/stplqt.f @@ -0,0 +1,270 @@ +*> \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 diff --git a/SRC/stplqt2.f b/SRC/stplqt2.f new file mode 100644 index 00000000..e8b9f19d --- /dev/null +++ b/SRC/stplqt2.f @@ -0,0 +1,312 @@ +*> \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 diff --git a/SRC/stpmlqt.f b/SRC/stpmlqt.f new file mode 100644 index 00000000..2dcdb0d1 --- /dev/null +++ b/SRC/stpmlqt.f @@ -0,0 +1,366 @@ +*> \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 diff --git a/SRC/zgelq.f b/SRC/zgelq.f new file mode 100644 index 00000000..2e188df9 --- /dev/null +++ b/SRC/zgelq.f @@ -0,0 +1,268 @@ +* +* 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 diff --git a/SRC/zgelqt.f b/SRC/zgelqt.f new file mode 100644 index 00000000..d726db78 --- /dev/null +++ b/SRC/zgelqt.f @@ -0,0 +1,210 @@ +*> \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 diff --git a/SRC/zgelqt3.f b/SRC/zgelqt3.f new file mode 100644 index 00000000..93e8cf31 --- /dev/null +++ b/SRC/zgelqt3.f @@ -0,0 +1,261 @@ +*> \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 diff --git a/SRC/zgemlq.f b/SRC/zgemlq.f new file mode 100644 index 00000000..f71b6fd8 --- /dev/null +++ b/SRC/zgemlq.f @@ -0,0 +1,261 @@ +* +* 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 diff --git a/SRC/zgemlqt.f b/SRC/zgemlqt.f new file mode 100644 index 00000000..6060f9ef --- /dev/null +++ b/SRC/zgemlqt.f @@ -0,0 +1,289 @@ +*> \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 diff --git a/SRC/zgemqr.f b/SRC/zgemqr.f new file mode 100644 index 00000000..c78fe4d0 --- /dev/null +++ b/SRC/zgemqr.f @@ -0,0 +1,268 @@ +* +* 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 diff --git a/SRC/zgeqr.f b/SRC/zgeqr.f new file mode 100644 index 00000000..18a7f100 --- /dev/null +++ b/SRC/zgeqr.f @@ -0,0 +1,267 @@ +* +* 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 diff --git a/SRC/zgetsls.f b/SRC/zgetsls.f new file mode 100644 index 00000000..dc523431 --- /dev/null +++ b/SRC/zgetsls.f @@ -0,0 +1,490 @@ +* 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 diff --git a/SRC/zlamswlq.f b/SRC/zlamswlq.f new file mode 100644 index 00000000..af0c62ef --- /dev/null +++ b/SRC/zlamswlq.f @@ -0,0 +1,407 @@ +* +* 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 diff --git a/SRC/zlamtsqr.f b/SRC/zlamtsqr.f new file mode 100644 index 00000000..21513027 --- /dev/null +++ b/SRC/zlamtsqr.f @@ -0,0 +1,405 @@ +* +* 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 diff --git a/SRC/zlaswlq.f b/SRC/zlaswlq.f new file mode 100644 index 00000000..67178c29 --- /dev/null +++ b/SRC/zlaswlq.f @@ -0,0 +1,258 @@ +* +* 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 diff --git a/SRC/zlatsqr.f b/SRC/zlatsqr.f new file mode 100644 index 00000000..aa2cdef9 --- /dev/null +++ b/SRC/zlatsqr.f @@ -0,0 +1,255 @@ +* +* 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 diff --git a/SRC/ztplqt.f b/SRC/ztplqt.f new file mode 100644 index 00000000..2d75d76e --- /dev/null +++ b/SRC/ztplqt.f @@ -0,0 +1,270 @@ +*> \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 diff --git a/SRC/ztplqt2.f b/SRC/ztplqt2.f new file mode 100644 index 00000000..7ad75719 --- /dev/null +++ b/SRC/ztplqt2.f @@ -0,0 +1,333 @@ +*> \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 diff --git a/SRC/ztpmlqt.f b/SRC/ztpmlqt.f new file mode 100644 index 00000000..ebdefee5 --- /dev/null +++ b/SRC/ztpmlqt.f @@ -0,0 +1,366 @@ +*> \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 diff --git a/TESTING/.DS_Store b/TESTING/.DS_Store Binary files differnew file mode 100644 index 00000000..96586931 --- /dev/null +++ b/TESTING/.DS_Store diff --git a/TESTING/LIN/Makefile b/TESTING/LIN/Makefile index 3232f0fd..4b82e0b1 100644 --- a/TESTING/LIN/Makefile +++ b/TESTING/LIN/Makefile @@ -45,16 +45,16 @@ ALINTST = \ 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 \ @@ -70,11 +70,13 @@ SLINTST = schkaa.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 \ @@ -86,11 +88,11 @@ endif 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 \ @@ -99,7 +101,7 @@ CLINTST = cchkaa.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 \ @@ -115,7 +117,9 @@ CLINTST = cchkaa.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 \ @@ -129,10 +133,10 @@ DLINTST = dchkaa.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 \ @@ -148,12 +152,14 @@ DLINTST = dchkaa.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 \ @@ -165,11 +171,11 @@ endif 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 \ @@ -178,7 +184,7 @@ ZLINTST = zchkaa.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 \ @@ -194,7 +200,9 @@ ZLINTST = zchkaa.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 \ @@ -218,26 +226,26 @@ ZCLINTST = zchkab.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 @@ -251,39 +259,39 @@ xlintsts : $(ALINTST) $(SLINTST) $(SCLNTST) ../../$(LAPACKLIB) 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 $@ @@ -324,7 +332,7 @@ $(ZLINTST): $(FRC) FRC: @FRC=$(FRC) - + clean: rm -f *.o @@ -336,8 +344,8 @@ cchkaa.o: cchkaa.f $(FORTRAN) $(DRVOPTS) -c $< -o $@ zchkaa.o: zchkaa.f $(FORTRAN) $(DRVOPTS) -c $< -o $@ - -.f.o: + +.f.o: $(FORTRAN) $(OPTS) -c $< -o $@ .NOTPARALLEL: diff --git a/TESTING/LIN/alaerh.f b/TESTING/LIN/alaerh.f index 4fec4522..2f58e85c 100644 --- a/TESTING/LIN/alaerh.f +++ b/TESTING/LIN/alaerh.f @@ -2,15 +2,15 @@ * * =========== 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 @@ -18,7 +18,7 @@ * INTEGER IMAT, INFO, INFOE, KL, KU, M, N, N5, NERRS, * $ NFAIL, NOUT * .. -* +* * *> \par Purpose: * ============= @@ -134,10 +134,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 November 2013 * @@ -490,7 +490,6 @@ 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 @@ -499,8 +498,6 @@ * 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; * diff --git a/TESTING/LIN/alahd.f b/TESTING/LIN/alahd.f index 995a5444..e482a26d 100644 --- a/TESTING/LIN/alahd.f +++ b/TESTING/LIN/alahd.f @@ -53,8 +53,6 @@ *> 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, @@ -357,28 +355,6 @@ 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, @@ -591,7 +567,7 @@ * 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 @@ -658,6 +634,45 @@ 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. @@ -698,6 +713,11 @@ 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 * @@ -970,7 +990,8 @@ 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' ) @@ -990,6 +1011,30 @@ 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 * diff --git a/TESTING/LIN/cchkaa.f b/TESTING/LIN/cchkaa.f index 1f8b2c65..ac71efce 100644 --- a/TESTING/LIN/cchkaa.f +++ b/TESTING/LIN/cchkaa.f @@ -2,14 +2,14 @@ * * =========== 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: * ============= @@ -51,7 +51,6 @@ *> 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 @@ -98,22 +97,22 @@ * 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 * * ===================================================================== * @@ -642,33 +641,6 @@ 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, @@ -895,6 +867,7 @@ ELSE WRITE( NOUT, FMT = 9989 )PATH END IF + * ELSE IF( LSAMEN( 2, C2, 'RQ' ) ) THEN * @@ -953,6 +926,7 @@ ELSE WRITE( NOUT, FMT = 9989 )PATH END IF + * ELSE IF( LSAMEN( 2, C2, 'LS' ) ) THEN * @@ -976,7 +950,7 @@ * 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 @@ -987,7 +961,40 @@ * 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 diff --git a/TESTING/LIN/cchklqt.f b/TESTING/LIN/cchklqt.f new file mode 100644 index 00000000..d6c4f7e1 --- /dev/null +++ b/TESTING/LIN/cchklqt.f @@ -0,0 +1,210 @@ +*> \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 diff --git a/TESTING/LIN/cchklqtp.f b/TESTING/LIN/cchklqtp.f new file mode 100644 index 00000000..5e573e4c --- /dev/null +++ b/TESTING/LIN/cchklqtp.f @@ -0,0 +1,215 @@ +*> \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 diff --git a/TESTING/LIN/cchktsqr.f b/TESTING/LIN/cchktsqr.f new file mode 100644 index 00000000..8c55f399 --- /dev/null +++ b/TESTING/LIN/cchktsqr.f @@ -0,0 +1,257 @@ +*> \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 diff --git a/TESTING/LIN/cdrvls.f b/TESTING/LIN/cdrvls.f index 623d94e3..2e354a61 100644 --- a/TESTING/LIN/cdrvls.f +++ b/TESTING/LIN/cdrvls.f @@ -2,31 +2,30 @@ * * =========== 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: * ============= @@ -196,20 +195,19 @@ * 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, -- @@ -234,7 +232,7 @@ * * .. Parameters .. INTEGER NTESTS - PARAMETER ( NTESTS = 14 ) + PARAMETER ( NTESTS = 16 ) INTEGER SMLSIZ PARAMETER ( SMLSIZ = 25 ) REAL ONE, ZERO @@ -249,7 +247,7 @@ 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 .. @@ -257,17 +255,17 @@ 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 @@ -317,13 +315,19 @@ * 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 @@ -433,6 +437,110 @@ 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 @@ -548,8 +656,8 @@ 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 @@ -567,8 +675,8 @@ 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 * @@ -637,7 +745,7 @@ * 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 ) @@ -663,6 +771,9 @@ $ ', 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 diff --git a/TESTING/LIN/cerrlqt.f b/TESTING/LIN/cerrlqt.f new file mode 100644 index 00000000..008cb0a9 --- /dev/null +++ b/TESTING/LIN/cerrlqt.f @@ -0,0 +1,197 @@ +*> \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 diff --git a/TESTING/LIN/cerrlqtp.f b/TESTING/LIN/cerrlqtp.f new file mode 100644 index 00000000..45797ddb --- /dev/null +++ b/TESTING/LIN/cerrlqtp.f @@ -0,0 +1,225 @@ +*> \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 diff --git a/TESTING/LIN/cerrtsqr.f b/TESTING/LIN/cerrtsqr.f new file mode 100644 index 00000000..3ca8b379 --- /dev/null +++ b/TESTING/LIN/cerrtsqr.f @@ -0,0 +1,243 @@ +*> \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 diff --git a/TESTING/LIN/clqt04.f b/TESTING/LIN/clqt04.f new file mode 100644 index 00000000..cdab2dfd --- /dev/null +++ b/TESTING/LIN/clqt04.f @@ -0,0 +1,262 @@ +*> \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 + diff --git a/TESTING/LIN/clqt05.f b/TESTING/LIN/clqt05.f new file mode 100644 index 00000000..22ffcc05 --- /dev/null +++ b/TESTING/LIN/clqt05.f @@ -0,0 +1,289 @@ +*> \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 diff --git a/TESTING/LIN/ctsqr01.f b/TESTING/LIN/ctsqr01.f new file mode 100644 index 00000000..a94f89f2 --- /dev/null +++ b/TESTING/LIN/ctsqr01.f @@ -0,0 +1,427 @@ +*> \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 diff --git a/TESTING/LIN/dchkaa.f b/TESTING/LIN/dchkaa.f index 9e7a14ab..70f9a52a 100644 --- a/TESTING/LIN/dchkaa.f +++ b/TESTING/LIN/dchkaa.f @@ -2,14 +2,14 @@ * * =========== 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: * ============= @@ -49,7 +49,6 @@ *> 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 @@ -95,10 +94,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 * @@ -162,7 +161,9 @@ $ 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 @@ -665,34 +666,6 @@ 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, @@ -891,13 +864,13 @@ 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 @@ -908,7 +881,40 @@ * 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 diff --git a/TESTING/LIN/dchklqt.f b/TESTING/LIN/dchklqt.f new file mode 100644 index 00000000..1726090e --- /dev/null +++ b/TESTING/LIN/dchklqt.f @@ -0,0 +1,210 @@ +*> \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 diff --git a/TESTING/LIN/dchklqtp.f b/TESTING/LIN/dchklqtp.f new file mode 100644 index 00000000..1cc82ec5 --- /dev/null +++ b/TESTING/LIN/dchklqtp.f @@ -0,0 +1,215 @@ +*> \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 diff --git a/TESTING/LIN/dchktsqr.f b/TESTING/LIN/dchktsqr.f new file mode 100644 index 00000000..0c3de46e --- /dev/null +++ b/TESTING/LIN/dchktsqr.f @@ -0,0 +1,257 @@ +*> \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 diff --git a/TESTING/LIN/ddrvls.f b/TESTING/LIN/ddrvls.f index f92f3455..b9b798cb 100644 --- a/TESTING/LIN/ddrvls.f +++ b/TESTING/LIN/ddrvls.f @@ -2,8 +2,8 @@ * * =========== 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: * =========== @@ -11,7 +11,7 @@ * 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 @@ -24,14 +24,14 @@ * 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 * @@ -46,14 +46,14 @@ *> .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 @@ -189,10 +189,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 November 2015 * @@ -225,7 +225,7 @@ * * .. Parameters .. INTEGER NTESTS - PARAMETER ( NTESTS = 14 ) + PARAMETER ( NTESTS = 16 ) INTEGER SMLSIZ PARAMETER ( SMLSIZ = 25 ) DOUBLE PRECISION ONE, TWO, ZERO @@ -234,10 +234,10 @@ * .. 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 .. @@ -308,8 +308,14 @@ * 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 ) @@ -317,7 +323,8 @@ $ 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 @@ -426,6 +433,110 @@ 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 @@ -628,7 +739,7 @@ * 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 ) @@ -637,7 +748,7 @@ NFAIL = NFAIL + 1 END IF 90 CONTINUE - NRUN = NRUN + 12 + NRUN = NRUN + 12 * 100 CONTINUE 110 CONTINUE @@ -654,6 +765,9 @@ $ ', 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 diff --git a/TESTING/LIN/derrlqt.f b/TESTING/LIN/derrlqt.f new file mode 100644 index 00000000..5a768f01 --- /dev/null +++ b/TESTING/LIN/derrlqt.f @@ -0,0 +1,197 @@ +*> \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 diff --git a/TESTING/LIN/derrlqtp.f b/TESTING/LIN/derrlqtp.f new file mode 100644 index 00000000..ae118af9 --- /dev/null +++ b/TESTING/LIN/derrlqtp.f @@ -0,0 +1,225 @@ +*> \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 diff --git a/TESTING/LIN/derrtsqr.f b/TESTING/LIN/derrtsqr.f new file mode 100644 index 00000000..aa9f3674 --- /dev/null +++ b/TESTING/LIN/derrtsqr.f @@ -0,0 +1,243 @@ +*> \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 diff --git a/TESTING/LIN/dlqt04.f b/TESTING/LIN/dlqt04.f new file mode 100644 index 00000000..216ef3ea --- /dev/null +++ b/TESTING/LIN/dlqt04.f @@ -0,0 +1,259 @@ +*> \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 + diff --git a/TESTING/LIN/dlqt05.f b/TESTING/LIN/dlqt05.f new file mode 100644 index 00000000..b357dcb5 --- /dev/null +++ b/TESTING/LIN/dlqt05.f @@ -0,0 +1,286 @@ +*> \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 diff --git a/TESTING/LIN/dtplqt.f b/TESTING/LIN/dtplqt.f new file mode 100644 index 00000000..27965442 --- /dev/null +++ b/TESTING/LIN/dtplqt.f @@ -0,0 +1,270 @@ +*> \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 diff --git a/TESTING/LIN/dtsqr01.f b/TESTING/LIN/dtsqr01.f new file mode 100644 index 00000000..29d4b63e --- /dev/null +++ b/TESTING/LIN/dtsqr01.f @@ -0,0 +1,428 @@ +*> \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 diff --git a/TESTING/LIN/ilaenv.f b/TESTING/LIN/ilaenv.f index 80479382..67cc587c 100644 --- a/TESTING/LIN/ilaenv.f +++ b/TESTING/LIN/ilaenv.f @@ -2,20 +2,20 @@ * * =========== 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: * ============= @@ -114,10 +114,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 November 2011 * @@ -162,6 +162,8 @@ * * ===================================================================== * +* .. Local Scalars .. + CHARACTER C1*1, C2*2, C4*2, C3*3, SUBNAM*6 * .. Intrinsic Functions .. INTRINSIC INT, MIN, REAL * .. @@ -184,7 +186,21 @@ * * 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 * diff --git a/TESTING/LIN/schkaa.f b/TESTING/LIN/schkaa.f index a6bfa101..480dd1d2 100644 --- a/TESTING/LIN/schkaa.f +++ b/TESTING/LIN/schkaa.f @@ -2,14 +2,14 @@ * * =========== 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: * ============= @@ -94,10 +94,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 * @@ -664,33 +664,6 @@ 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, @@ -895,7 +868,7 @@ * 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 @@ -906,7 +879,40 @@ * 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 diff --git a/TESTING/LIN/schklqt.f b/TESTING/LIN/schklqt.f new file mode 100644 index 00000000..fd449b1a --- /dev/null +++ b/TESTING/LIN/schklqt.f @@ -0,0 +1,210 @@ +*> \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 diff --git a/TESTING/LIN/schklqtp.f b/TESTING/LIN/schklqtp.f new file mode 100644 index 00000000..d85ef8d1 --- /dev/null +++ b/TESTING/LIN/schklqtp.f @@ -0,0 +1,215 @@ +*> \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 diff --git a/TESTING/LIN/schktsqr.f b/TESTING/LIN/schktsqr.f new file mode 100644 index 00000000..a4303143 --- /dev/null +++ b/TESTING/LIN/schktsqr.f @@ -0,0 +1,257 @@ +*> \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 diff --git a/TESTING/LIN/sdrvls.f b/TESTING/LIN/sdrvls.f index 4db6f887..d18ce595 100644 --- a/TESTING/LIN/sdrvls.f +++ b/TESTING/LIN/sdrvls.f @@ -2,8 +2,8 @@ * * =========== 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: * =========== @@ -11,7 +11,7 @@ * 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 @@ -24,14 +24,14 @@ * 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 * @@ -46,14 +46,14 @@ *> .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 @@ -189,14 +189,14 @@ * 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, @@ -225,7 +225,7 @@ * * .. Parameters .. INTEGER NTESTS - PARAMETER ( NTESTS = 14 ) + PARAMETER ( NTESTS = 16 ) INTEGER SMLSIZ PARAMETER ( SMLSIZ = 25 ) REAL ONE, TWO, ZERO @@ -234,10 +234,10 @@ * .. 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 .. @@ -251,11 +251,11 @@ * .. 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 @@ -273,7 +273,7 @@ * * 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 @@ -299,6 +299,8 @@ 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 ) @@ -306,8 +308,14 @@ * 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 ) @@ -315,7 +323,8 @@ $ 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 @@ -424,6 +433,110 @@ 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 @@ -626,7 +739,7 @@ * 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 ) @@ -635,7 +748,7 @@ NFAIL = NFAIL + 1 END IF 90 CONTINUE - NRUN = NRUN + 12 + NRUN = NRUN + 12 * 100 CONTINUE 110 CONTINUE @@ -652,6 +765,9 @@ $ ', 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 diff --git a/TESTING/LIN/serrlqt.f b/TESTING/LIN/serrlqt.f new file mode 100644 index 00000000..2c2c575b --- /dev/null +++ b/TESTING/LIN/serrlqt.f @@ -0,0 +1,197 @@ +*> \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 diff --git a/TESTING/LIN/serrlqtp.f b/TESTING/LIN/serrlqtp.f new file mode 100644 index 00000000..319ee91c --- /dev/null +++ b/TESTING/LIN/serrlqtp.f @@ -0,0 +1,225 @@ +*> \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 diff --git a/TESTING/LIN/serrtsqr.f b/TESTING/LIN/serrtsqr.f new file mode 100644 index 00000000..0ba37978 --- /dev/null +++ b/TESTING/LIN/serrtsqr.f @@ -0,0 +1,243 @@ +*> \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 diff --git a/TESTING/LIN/slqt04.f b/TESTING/LIN/slqt04.f new file mode 100644 index 00000000..debae5ca --- /dev/null +++ b/TESTING/LIN/slqt04.f @@ -0,0 +1,259 @@ +*> \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 + diff --git a/TESTING/LIN/slqt05.f b/TESTING/LIN/slqt05.f new file mode 100644 index 00000000..5ad3a4b2 --- /dev/null +++ b/TESTING/LIN/slqt05.f @@ -0,0 +1,279 @@ +* 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 diff --git a/TESTING/LIN/stplqt.f b/TESTING/LIN/stplqt.f new file mode 100644 index 00000000..adbbfe8b --- /dev/null +++ b/TESTING/LIN/stplqt.f @@ -0,0 +1,253 @@ +* 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 diff --git a/TESTING/LIN/stsqr01.f b/TESTING/LIN/stsqr01.f new file mode 100644 index 00000000..dbaf3aac --- /dev/null +++ b/TESTING/LIN/stsqr01.f @@ -0,0 +1,428 @@ +*> \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 diff --git a/TESTING/LIN/zchkaa.f b/TESTING/LIN/zchkaa.f index 90b98a2e..2aae1a10 100644 --- a/TESTING/LIN/zchkaa.f +++ b/TESTING/LIN/zchkaa.f @@ -2,14 +2,14 @@ * * =========== 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: * ============= @@ -50,7 +50,6 @@ *> 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 @@ -69,6 +68,9 @@ *> ZEQ *> ZQT *> ZQX +*> ZTQ +*> ZXQ +*> ZTS *> \endverbatim * * Parameters: @@ -98,22 +100,22 @@ * 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 * * ===================================================================== * @@ -166,7 +168,8 @@ $ 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 @@ -640,33 +643,6 @@ 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, @@ -975,7 +951,7 @@ * 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 @@ -986,7 +962,73 @@ * 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 diff --git a/TESTING/LIN/zchklqt.f b/TESTING/LIN/zchklqt.f new file mode 100644 index 00000000..e15793be --- /dev/null +++ b/TESTING/LIN/zchklqt.f @@ -0,0 +1,210 @@ +*> \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 diff --git a/TESTING/LIN/zchklqtp.f b/TESTING/LIN/zchklqtp.f new file mode 100644 index 00000000..10f7363a --- /dev/null +++ b/TESTING/LIN/zchklqtp.f @@ -0,0 +1,215 @@ +*> \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 diff --git a/TESTING/LIN/zchktsqr.f b/TESTING/LIN/zchktsqr.f new file mode 100644 index 00000000..c79a92b7 --- /dev/null +++ b/TESTING/LIN/zchktsqr.f @@ -0,0 +1,257 @@ +*> \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 diff --git a/TESTING/LIN/zdrvls.f b/TESTING/LIN/zdrvls.f index 95a7ff35..72cb48e3 100644 --- a/TESTING/LIN/zdrvls.f +++ b/TESTING/LIN/zdrvls.f @@ -2,8 +2,8 @@ * * =========== 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: * =========== @@ -11,7 +11,7 @@ * 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 @@ -25,7 +25,7 @@ * COMPLEX*16 A( * ), B( * ), C( * ), COPYA( * ), COPYB( * ), * $ WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -195,10 +195,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 November 2015 * @@ -232,7 +232,7 @@ * * .. Parameters .. INTEGER NTESTS - PARAMETER ( NTESTS = 14 ) + PARAMETER ( NTESTS = 16 ) INTEGER SMLSIZ PARAMETER ( SMLSIZ = 25 ) DOUBLE PRECISION ONE, ZERO @@ -247,7 +247,7 @@ 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 .. @@ -262,7 +262,7 @@ 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 @@ -315,13 +315,19 @@ * 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 @@ -431,6 +437,110 @@ 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 @@ -635,7 +745,7 @@ * 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 ) @@ -661,6 +771,9 @@ $ ', 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 diff --git a/TESTING/LIN/zerrlqt.f b/TESTING/LIN/zerrlqt.f new file mode 100644 index 00000000..fd6b4527 --- /dev/null +++ b/TESTING/LIN/zerrlqt.f @@ -0,0 +1,197 @@ +*> \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 diff --git a/TESTING/LIN/zerrlqtp.f b/TESTING/LIN/zerrlqtp.f new file mode 100644 index 00000000..25a079ec --- /dev/null +++ b/TESTING/LIN/zerrlqtp.f @@ -0,0 +1,225 @@ +*> \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 diff --git a/TESTING/LIN/zerrtsqr.f b/TESTING/LIN/zerrtsqr.f new file mode 100644 index 00000000..19c99805 --- /dev/null +++ b/TESTING/LIN/zerrtsqr.f @@ -0,0 +1,243 @@ +*> \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 diff --git a/TESTING/LIN/zlqt04.f b/TESTING/LIN/zlqt04.f new file mode 100644 index 00000000..a1aff90e --- /dev/null +++ b/TESTING/LIN/zlqt04.f @@ -0,0 +1,262 @@ +*> \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 + diff --git a/TESTING/LIN/zlqt05.f b/TESTING/LIN/zlqt05.f new file mode 100644 index 00000000..676c95b8 --- /dev/null +++ b/TESTING/LIN/zlqt05.f @@ -0,0 +1,289 @@ +*> \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 diff --git a/TESTING/LIN/ztsqr01.f b/TESTING/LIN/ztsqr01.f new file mode 100644 index 00000000..5f39ae7e --- /dev/null +++ b/TESTING/LIN/ztsqr01.f @@ -0,0 +1,427 @@ +*> \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 diff --git a/TESTING/ctest.in b/TESTING/ctest.in index 95a7b0dd..b8a197a9 100644..100755 --- a/TESTING/ctest.in +++ b/TESTING/ctest.in @@ -42,3 +42,6 @@ CLS 6 List types on next line if 0 < NTYPES < 6 CEQ CQT CQX +CXQ +CTQ +CTS diff --git a/TESTING/dtest.in b/TESTING/dtest.in index a2343db1..fd061441 100644..100755 --- a/TESTING/dtest.in +++ b/TESTING/dtest.in @@ -39,3 +39,6 @@ DLS 6 List types on next line if 0 < NTYPES < 6 DEQ DQT DQX +DXQ +DTQ +DTS
\ No newline at end of file diff --git a/TESTING/stest.in b/TESTING/stest.in index 865adfb7..16529646 100644..100755 --- a/TESTING/stest.in +++ b/TESTING/stest.in @@ -39,3 +39,6 @@ SLS 6 List types on next line if 0 < NTYPES < 6 SEQ SQT SQX +SXQ +STQ +STS diff --git a/TESTING/ztest.in b/TESTING/ztest.in index 72a51351..f3eabb5e 100644..100755 --- a/TESTING/ztest.in +++ b/TESTING/ztest.in @@ -42,3 +42,6 @@ ZLS 6 List types on next line if 0 < NTYPES < 6 ZEQ ZQT ZQX +ZXQ +ZTQ +ZTS diff --git a/lapack-1 b/lapack-1 deleted file mode 160000 -Subproject 44f54c02c6242ece672619df26752d27ab5a07c |