floraachy/OpenBLAS
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Deprecate ?GELQS and ?GEQRS from TESTING/LIN (Reference-LAPACK PR 900) (#4307)

Browse Source 
* Move ?GELQS and ?GEQRS from TESTING/LIN to DEPRECATED (Reference-LAPACK PR 900)

* Add f2c-converted versions of ?GELQS and ?GEQRS
This commit is contained in:
Martin Kroeker
2023-11-12 10:54:39 +01:00
committed by GitHub
parent 00ef1bb58a
commit 58427ff74d
36 changed files with 3934 additions and 278 deletions
Download Patch File Download Diff File Expand all files Collapse all files
lapack-netlib/TESTING/LIN/CMakeLists.txt
+4 -4
View File
@@ -20,7 +20,7 @@ set(SLINTST schkaa.F
serrgt.f serrlq.f serrls.f
serrps.f serrql.f serrqp.f serrqr.f
serrrq.f serrtr.f serrtz.f
sgbt01.f sgbt02.f sgbt05.f sgelqs.f sgeqls.f sgeqrs.f
sgbt01.f sgbt02.f sgbt05.f sgeqls.f
sgerqs.f sget01.f sget02.f
sget03.f sget04.f sget06.f sget07.f sgtt01.f sgtt02.f
sgtt05.f slaptm.f slarhs.f slatb4.f slatb5.f slattb.f slattp.f
@@ -70,7 +70,7 @@ set(CLINTST cchkaa.F
cerrgt.f cerrlq.f
cerrls.f cerrps.f cerrql.f cerrqp.f
cerrqr.f cerrrq.f cerrtr.f cerrtz.f
cgbt01.f cgbt02.f cgbt05.f cgelqs.f cgeqls.f cgeqrs.f
cgbt01.f cgbt02.f cgbt05.f cgeqls.f
cgerqs.f cget01.f cget02.f
cget03.f cget04.f cget07.f cgtt01.f cgtt02.f
cgtt05.f chet01.f chet01_rook.f chet01_3.f
@@ -121,7 +121,7 @@ set(DLINTST dchkaa.F
derrgt.f derrlq.f derrls.f
derrps.f derrql.f derrqp.f derrqr.f
derrrq.f derrtr.f derrtz.f
dgbt01.f dgbt02.f dgbt05.f dgelqs.f dgeqls.f dgeqrs.f
dgbt01.f dgbt02.f dgbt05.f dgeqls.f
dgerqs.f dget01.f dget02.f
dget03.f dget04.f dget06.f dget07.f dgtt01.f dgtt02.f
dgtt05.f dlaptm.f dlarhs.f dlatb4.f dlatb5.f dlattb.f dlattp.f
@@ -172,7 +172,7 @@ set(ZLINTST zchkaa.F
zerrgt.f zerrlq.f
zerrls.f zerrps.f zerrql.f zerrqp.f
zerrqr.f zerrrq.f zerrtr.f zerrtz.f
zgbt01.f zgbt02.f zgbt05.f zgelqs.f zgeqls.f zgeqrs.f
zgbt01.f zgbt02.f zgbt05.f zgeqls.f
zgerqs.f zget01.f zget02.f
zget03.f zget04.f zget07.f zgtt01.f zgtt02.f
zgtt05.f zhet01.f zhet01_rook.f zhet01_3.f
lapack-netlib/TESTING/LIN/Makefile
+4 -4
View File
@@ -55,7 +55,7 @@ SLINTST = schkaa.o \
serrgt.o serrlq.o serrls.o \
serrps.o serrql.o serrqp.o serrqr.o \
serrrq.o serrtr.o serrtz.o \
sgbt01.o sgbt02.o sgbt05.o sgelqs.o sgeqls.o sgeqrs.o \
sgbt01.o sgbt02.o sgbt05.o sgeqls.o \
sgerqs.o sget01.o sget02.o \
sget03.o sget04.o sget06.o sget07.o sgtt01.o sgtt02.o \
sgtt05.o slaptm.o slarhs.o slatb4.o slatb5.o slattb.o slattp.o \
@@ -100,7 +100,7 @@ CLINTST = cchkaa.o \
cerrgt.o cerrlq.o \
cerrls.o cerrps.o cerrql.o cerrqp.o \
cerrqr.o cerrrq.o cerrtr.o cerrtz.o \
cgbt01.o cgbt02.o cgbt05.o cgelqs.o cgeqls.o cgeqrs.o \
cgbt01.o cgbt02.o cgbt05.o cgeqls.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_3.o chet01_aa.o \
@@ -147,7 +147,7 @@ DLINTST = dchkaa.o \
derrgt.o derrlq.o derrls.o \
derrps.o derrql.o derrqp.o derrqr.o \
derrrq.o derrtr.o derrtz.o \
dgbt01.o dgbt02.o dgbt05.o dgelqs.o dgeqls.o dgeqrs.o \
dgbt01.o dgbt02.o dgbt05.o dgeqls.o \
dgerqs.o dget01.o dget02.o \
dget03.o dget04.o dget06.o dget07.o dgtt01.o dgtt02.o \
dgtt05.o dlaptm.o dlarhs.o dlatb4.o dlatb5.o dlattb.o dlattp.o \
@@ -192,7 +192,7 @@ ZLINTST = zchkaa.o \
zerrgt.o zerrlq.o \
zerrls.o zerrps.o zerrql.o zerrqp.o \
zerrqr.o zerrrq.o zerrtr.o zerrtz.o \
zgbt01.o zgbt02.o zgbt05.o zgelqs.o zgeqls.o zgeqrs.o \
zgbt01.o zgbt02.o zgbt05.o zgeqls.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_3.o zhet01_aa.o \
lapack-netlib/TESTING/LIN/cchklq.f
+13 -7
View File
@@ -235,7 +235,7 @@
REAL RESULT( NTESTS )
* ..
* .. External Subroutines ..
EXTERNAL ALAERH, ALAHD, ALASUM, CERRLQ, CGELQS, CGET02,
EXTERNAL ALAERH, ALAHD, ALASUM, CERRLQ, CGELS, CGET02,
$ CLACPY, CLARHS, CLATB4, CLATMS, CLQT01, CLQT02,
$ CLQT03, XLAENV
* ..
@@ -370,7 +370,7 @@
$ WORK, LWORK, RWORK, RESULT( 3 ) )
NT = NT + 4
*
* If M>=N and K=N, call CGELQS to solve a system
* If M<=N and K=M, call CGELS to solve a system
* with NRHS right hand sides and compute the
* residual.
*
@@ -387,14 +387,20 @@
*
CALL CLACPY( 'Full', M, NRHS, B, LDA, X,
$ LDA )
SRNAMT = 'CGELQS'
CALL CGELQS( M, N, NRHS, AF, LDA, TAU, X,
$ LDA, WORK, LWORK, INFO )
*
* Check error code from CGELQS.
* Reset AF to the original matrix. CGELS
* factors the matrix before solving the system.
*
CALL CLACPY( 'Full', M, N, A, LDA, AF, LDA )
*
SRNAMT = 'CGELS'
CALL CGELS( 'No transpose', M, N, NRHS, AF,
$ LDA, X, LDA, WORK, LWORK, INFO )
*
* Check error code from CGELS.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'CGELQS', INFO, 0, ' ',
$ CALL ALAERH( PATH, 'CGELS', INFO, 0, 'N',
$ M, N, NRHS, -1, NB, IMAT,
$ NFAIL, NERRS, NOUT )
*
lapack-netlib/TESTING/LIN/cchkqr.f
+14 -8
View File
@@ -244,7 +244,7 @@
EXTERNAL CGENND
* ..
* .. External Subroutines ..
EXTERNAL ALAERH, ALAHD, ALASUM, CERRQR, CGEQRS, CGET02,
EXTERNAL ALAERH, ALAHD, ALASUM, CERRQR, CGELS, CGET02,
$ CLACPY, CLARHS, CLATB4, CLATMS, CQRT01,
$ CQRT01P, CQRT02, CQRT03, XLAENV
* ..
@@ -371,7 +371,7 @@
IF( .NOT. CGENND( M, N, AF, LDA ) )
$ RESULT( 9 ) = 2*THRESH
NT = NT + 1
ELSE IF( M.GE.N ) THEN
ELSE IF( M.GE.N ) THEN
*
* Test CUNGQR, using factorization
* returned by CQRT01
@@ -388,7 +388,7 @@
$ WORK, LWORK, RWORK, RESULT( 3 ) )
NT = NT + 4
*
* If M>=N and K=N, call CGEQRS to solve a system
* If M>=N and K=N, call CGELS to solve a system
* with NRHS right hand sides and compute the
* residual.
*
@@ -405,14 +405,20 @@
*
CALL CLACPY( 'Full', M, NRHS, B, LDA, X,
$ LDA )
SRNAMT = 'CGEQRS'
CALL CGEQRS( M, N, NRHS, AF, LDA, TAU, X,
$ LDA, WORK, LWORK, INFO )
*
* Check error code from CGEQRS.
* Reset AF to the original matrix. CGELS
* factors the matrix before solving the system.
*
CALL CLACPY( 'Full', M, N, A, LDA, AF, LDA )
*
SRNAMT = 'CGELS'
CALL CGELS( 'No transpose', M, N, NRHS, AF,
$ LDA, X, LDA, WORK, LWORK, INFO )
*
* Check error code from CGELS.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'CGEQRS', INFO, 0, ' ',
$ CALL ALAERH( PATH, 'CGELS', INFO, 0, 'N',
$ M, N, NRHS, -1, NB, IMAT,
$ NFAIL, NERRS, NOUT )
*
lapack-netlib/TESTING/LIN/cerrlq.f
+1 -26
View File
@@ -76,7 +76,7 @@
$ W( NMAX ), X( NMAX )
* ..
* .. External Subroutines ..
EXTERNAL ALAESM, CGELQ2, CGELQF, CGELQS, CHKXER, CUNGL2,
EXTERNAL ALAESM, CGELQ2, CGELQF, CHKXER, CUNGL2,
$ CUNGLQ, CUNML2, CUNMLQ
* ..
* .. Scalars in Common ..
@@ -140,31 +140,6 @@
CALL CGELQ2( 2, 1, A, 1, B, W, INFO )
CALL CHKXER( 'CGELQ2', INFOT, NOUT, LERR, OK )
*
* CGELQS
*
SRNAMT = 'CGELQS'
INFOT = 1
CALL CGELQS( -1, 0, 0, A, 1, X, B, 1, W, 1, INFO )
CALL CHKXER( 'CGELQS', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL CGELQS( 0, -1, 0, A, 1, X, B, 1, W, 1, INFO )
CALL CHKXER( 'CGELQS', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL CGELQS( 2, 1, 0, A, 2, X, B, 1, W, 1, INFO )
CALL CHKXER( 'CGELQS', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL CGELQS( 0, 0, -1, A, 1, X, B, 1, W, 1, INFO )
CALL CHKXER( 'CGELQS', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL CGELQS( 2, 2, 0, A, 1, X, B, 2, W, 1, INFO )
CALL CHKXER( 'CGELQS', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL CGELQS( 1, 2, 0, A, 1, X, B, 1, W, 1, INFO )
CALL CHKXER( 'CGELQS', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL CGELQS( 1, 1, 2, A, 1, X, B, 1, W, 1, INFO )
CALL CHKXER( 'CGELQS', INFOT, NOUT, LERR, OK )
*
* CUNGLQ
*
SRNAMT = 'CUNGLQ'
lapack-netlib/TESTING/LIN/cerrqr.f
+1 -26
View File
@@ -77,7 +77,7 @@
* ..
* .. External Subroutines ..
EXTERNAL ALAESM, CGEQR2, CGEQR2P, CGEQRF, CGEQRFP,
$ CGEQRS, CHKXER, CUNG2R, CUNGQR, CUNM2R,
$ CHKXER, CUNG2R, CUNGQR, CUNM2R,
$ CUNMQR
* ..
* .. Scalars in Common ..
@@ -170,31 +170,6 @@
CALL CGEQR2P( 2, 1, A, 1, B, W, INFO )
CALL CHKXER( 'CGEQR2P', INFOT, NOUT, LERR, OK )
*
* CGEQRS
*
SRNAMT = 'CGEQRS'
INFOT = 1
CALL CGEQRS( -1, 0, 0, A, 1, X, B, 1, W, 1, INFO )
CALL CHKXER( 'CGEQRS', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL CGEQRS( 0, -1, 0, A, 1, X, B, 1, W, 1, INFO )
CALL CHKXER( 'CGEQRS', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL CGEQRS( 1, 2, 0, A, 2, X, B, 2, W, 1, INFO )
CALL CHKXER( 'CGEQRS', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL CGEQRS( 0, 0, -1, A, 1, X, B, 1, W, 1, INFO )
CALL CHKXER( 'CGEQRS', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL CGEQRS( 2, 1, 0, A, 1, X, B, 2, W, 1, INFO )
CALL CHKXER( 'CGEQRS', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL CGEQRS( 2, 1, 0, A, 2, X, B, 1, W, 1, INFO )
CALL CHKXER( 'CGEQRS', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL CGEQRS( 1, 1, 2, A, 1, X, B, 1, W, 1, INFO )
CALL CHKXER( 'CGEQRS', INFOT, NOUT, LERR, OK )
*
* CUNGQR
*
SRNAMT = 'CUNGQR'
lapack-netlib/TESTING/LIN/cgelqs.f
-196
View File
@@ -1,196 +0,0 @@
*> \brief \b CGELQS
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE CGELQS( M, N, NRHS, A, LDA, TAU, B, LDB, WORK, LWORK,
* INFO )
*
* .. Scalar Arguments ..
* INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS
* ..
* .. Array Arguments ..
* COMPLEX A( LDA, * ), B( LDB, * ), TAU( * ),
* $ WORK( LWORK )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> Compute a minimum-norm solution
*> min || A*X - B ||
*> using the LQ factorization
*> A = L*Q
*> computed by CGELQF.
*> \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] NRHS
*> \verbatim
*> NRHS is INTEGER
*> The number of columns of B. NRHS >= 0.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is COMPLEX array, dimension (LDA,N)
*> Details of the LQ factorization of the original matrix A as
*> returned by CGELQF.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= M.
*> \endverbatim
*>
*> \param[in] TAU
*> \verbatim
*> TAU is COMPLEX array, dimension (M)
*> Details of the orthogonal matrix Q.
*> \endverbatim
*>
*> \param[in,out] B
*> \verbatim
*> B is COMPLEX array, dimension (LDB,NRHS)
*> On entry, the m-by-nrhs right hand side matrix B.
*> On exit, the n-by-nrhs solution matrix X.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*> LDB is INTEGER
*> The leading dimension of the array B. LDB >= N.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX array, dimension (LWORK)
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*> LWORK is INTEGER
*> The length of the array WORK. LWORK must be at least NRHS,
*> and should be at least NRHS*NB, where NB is the block size
*> for this environment.
*> \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.
*
*> \ingroup complex_lin
*
* =====================================================================
SUBROUTINE CGELQS( M, N, NRHS, A, LDA, TAU, B, LDB, WORK, LWORK,
$ INFO )
*
* -- LAPACK test routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS
* ..
* .. Array Arguments ..
COMPLEX A( LDA, * ), B( LDB, * ), TAU( * ),
$ WORK( LWORK )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX CZERO, CONE
PARAMETER ( CZERO = ( 0.0E+0, 0.0E+0 ),
$ CONE = ( 1.0E+0, 0.0E+0 ) )
* ..
* .. External Subroutines ..
EXTERNAL CLASET, CTRSM, CUNMLQ, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
IF( M.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.0 .OR. M.GT.N ) THEN
INFO = -2
ELSE IF( NRHS.LT.0 ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -5
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -8
ELSE IF( LWORK.LT.1 .OR. LWORK.LT.NRHS .AND. M.GT.0 .AND. N.GT.0 )
$ THEN
INFO = -10
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'CGELQS', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 .OR. NRHS.EQ.0 .OR. M.EQ.0 )
$ RETURN
*
* Solve L*X = B(1:m,:)
*
CALL CTRSM( 'Left', 'Lower', 'No transpose', 'Non-unit', M, NRHS,
$ CONE, A, LDA, B, LDB )
*
* Set B(m+1:n,:) to zero
*
IF( M.LT.N )
$ CALL CLASET( 'Full', N-M, NRHS, CZERO, CZERO, B( M+1, 1 ),
$ LDB )
*
* B := Q' * B
*
CALL CUNMLQ( 'Left', 'Conjugate transpose', N, NRHS, M, A, LDA,
$ TAU, B, LDB, WORK, LWORK, INFO )
*
RETURN
*
* End of CGELQS
*
END
lapack-netlib/TESTING/LIN/cgeqrs.f
-189
View File
@@ -1,189 +0,0 @@
*> \brief \b CGEQRS
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE CGEQRS( M, N, NRHS, A, LDA, TAU, B, LDB, WORK, LWORK,
* INFO )
*
* .. Scalar Arguments ..
* INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS
* ..
* .. Array Arguments ..
* COMPLEX A( LDA, * ), B( LDB, * ), TAU( * ),
* $ WORK( LWORK )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> Solve the least squares problem
*> min || A*X - B ||
*> using the QR factorization
*> A = Q*R
*> computed by CGEQRF.
*> \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] NRHS
*> \verbatim
*> NRHS is INTEGER
*> The number of columns of B. NRHS >= 0.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is COMPLEX array, dimension (LDA,N)
*> Details of the QR factorization of the original matrix A as
*> returned by CGEQRF.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= M.
*> \endverbatim
*>
*> \param[in] TAU
*> \verbatim
*> TAU is COMPLEX array, dimension (N)
*> Details of the orthogonal matrix Q.
*> \endverbatim
*>
*> \param[in,out] B
*> \verbatim
*> B is COMPLEX array, dimension (LDB,NRHS)
*> On entry, the m-by-nrhs right hand side matrix B.
*> On exit, the n-by-nrhs solution matrix X.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*> LDB is INTEGER
*> The leading dimension of the array B. LDB >= M.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX array, dimension (LWORK)
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*> LWORK is INTEGER
*> The length of the array WORK. LWORK must be at least NRHS,
*> and should be at least NRHS*NB, where NB is the block size
*> for this environment.
*> \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.
*
*> \ingroup complex_lin
*
* =====================================================================
SUBROUTINE CGEQRS( M, N, NRHS, A, LDA, TAU, B, LDB, WORK, LWORK,
$ INFO )
*
* -- LAPACK test routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS
* ..
* .. Array Arguments ..
COMPLEX A( LDA, * ), B( LDB, * ), TAU( * ),
$ WORK( LWORK )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX ONE
PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ) )
* ..
* .. External Subroutines ..
EXTERNAL CTRSM, CUNMQR, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input arguments.
*
INFO = 0
IF( M.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.0 .OR. N.GT.M ) THEN
INFO = -2
ELSE IF( NRHS.LT.0 ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -5
ELSE IF( LDB.LT.MAX( 1, M ) ) THEN
INFO = -8
ELSE IF( LWORK.LT.1 .OR. LWORK.LT.NRHS .AND. M.GT.0 .AND. N.GT.0 )
$ THEN
INFO = -10
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'CGEQRS', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 .OR. NRHS.EQ.0 .OR. M.EQ.0 )
$ RETURN
*
* B := Q' * B
*
CALL CUNMQR( 'Left', 'Conjugate transpose', M, NRHS, N, A, LDA,
$ TAU, B, LDB, WORK, LWORK, INFO )
*
* Solve R*X = B(1:n,:)
*
CALL CTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', N, NRHS,
$ ONE, A, LDA, B, LDB )
*
RETURN
*
* End of CGEQRS
*
END
lapack-netlib/TESTING/LIN/dchklq.f
+13 -7
View File
@@ -235,7 +235,7 @@
DOUBLE PRECISION RESULT( NTESTS )
* ..
* .. External Subroutines ..
EXTERNAL ALAERH, ALAHD, ALASUM, DERRLQ, DGELQS, DGET02,
EXTERNAL ALAERH, ALAHD, ALASUM, DERRLQ, DGELS, DGET02,
$ DLACPY, DLARHS, DLATB4, DLATMS, DLQT01, DLQT02,
$ DLQT03, XLAENV
* ..
@@ -373,7 +373,7 @@
$ WORK, LWORK, RWORK, RESULT( 3 ) )
NT = NT + 4
*
* If M>=N and K=N, call DGELQS to solve a system
* If M<=N and K=M, call DGELS to solve a system
* with NRHS right hand sides and compute the
* residual.
*
@@ -390,14 +390,20 @@
*
CALL DLACPY( 'Full', M, NRHS, B, LDA, X,
$ LDA )
SRNAMT = 'DGELQS'
CALL DGELQS( M, N, NRHS, AF, LDA, TAU, X,
$ LDA, WORK, LWORK, INFO )
*
* Check error code from DGELQS.
* Reset AF to the original matrix. DGELS
* factors the matrix before solving the system.
*
CALL DLACPY( 'Full', M, N, A, LDA, AF, LDA )
*
SRNAMT = 'DGELS'
CALL DGELS( 'No transpose', M, N, NRHS, AF,
$ LDA, X, LDA, WORK, LWORK, INFO )
*
* Check error code from DGELS.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'DGELQS', INFO, 0, ' ',
$ CALL ALAERH( PATH, 'DGELS', INFO, 0, 'N',
$ M, N, NRHS, -1, NB, IMAT,
$ NFAIL, NERRS, NOUT )
*
lapack-netlib/TESTING/LIN/dchkqr.f
+14 -8
View File
@@ -244,7 +244,7 @@
EXTERNAL DGENND
* ..
* .. External Subroutines ..
EXTERNAL ALAERH, ALAHD, ALASUM, DERRQR, DGEQRS, DGET02,
EXTERNAL ALAERH, ALAHD, ALASUM, DERRQR, DGELS, DGET02,
$ DLACPY, DLARHS, DLATB4, DLATMS, DQRT01,
$ DQRT01P, DQRT02, DQRT03, XLAENV
* ..
@@ -372,7 +372,7 @@
IF( .NOT. DGENND( M, N, AF, LDA ) )
$ RESULT( 9 ) = 2*THRESH
NT = NT + 1
ELSE IF( M.GE.N ) THEN
ELSE IF( M.GE.N ) THEN
*
* Test DORGQR, using factorization
* returned by DQRT01
@@ -389,7 +389,7 @@
$ WORK, LWORK, RWORK, RESULT( 3 ) )
NT = NT + 4
*
* If M>=N and K=N, call DGEQRS to solve a system
* If M>=N and K=N, call DGELS to solve a system
* with NRHS right hand sides and compute the
* residual.
*
@@ -406,14 +406,20 @@
*
CALL DLACPY( 'Full', M, NRHS, B, LDA, X,
$ LDA )
SRNAMT = 'DGEQRS'
CALL DGEQRS( M, N, NRHS, AF, LDA, TAU, X,
$ LDA, WORK, LWORK, INFO )
*
* Check error code from DGEQRS.
* Reset AF. DGELS overwrites the matrix with
* its factorization.
*
CALL DLACPY( 'Full', M, N, A, LDA, AF, LDA )
*
SRNAMT = 'DGELS'
CALL DGELS( 'No transpose', M, N, NRHS, AF,
$ LDA, X, LDA, WORK, LWORK, INFO )
*
* Check error code from DGELS.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'DGEQRS', INFO, 0, ' ',
$ CALL ALAERH( PATH, 'DGELS', INFO, 0, 'N',
$ M, N, NRHS, -1, NB, IMAT,
$ NFAIL, NERRS, NOUT )
*
lapack-netlib/TESTING/LIN/derrlq.f
+1 -26
View File
@@ -76,7 +76,7 @@
$ W( NMAX ), X( NMAX )
* ..
* .. External Subroutines ..
EXTERNAL ALAESM, CHKXER, DGELQ2, DGELQF, DGELQS, DORGL2,
EXTERNAL ALAESM, CHKXER, DGELQ2, DGELQF, DORGL2,
$ DORGLQ, DORML2, DORMLQ
* ..
* .. Scalars in Common ..
@@ -140,31 +140,6 @@
CALL DGELQ2( 2, 1, A, 1, B, W, INFO )
CALL CHKXER( 'DGELQ2', INFOT, NOUT, LERR, OK )
*
* DGELQS
*
SRNAMT = 'DGELQS'
INFOT = 1
CALL DGELQS( -1, 0, 0, A, 1, X, B, 1, W, 1, INFO )
CALL CHKXER( 'DGELQS', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DGELQS( 0, -1, 0, A, 1, X, B, 1, W, 1, INFO )
CALL CHKXER( 'DGELQS', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DGELQS( 2, 1, 0, A, 2, X, B, 1, W, 1, INFO )
CALL CHKXER( 'DGELQS', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DGELQS( 0, 0, -1, A, 1, X, B, 1, W, 1, INFO )
CALL CHKXER( 'DGELQS', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DGELQS( 2, 2, 0, A, 1, X, B, 2, W, 1, INFO )
CALL CHKXER( 'DGELQS', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL DGELQS( 1, 2, 0, A, 1, X, B, 1, W, 1, INFO )
CALL CHKXER( 'DGELQS', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL DGELQS( 1, 1, 2, A, 1, X, B, 1, W, 1, INFO )
CALL CHKXER( 'DGELQS', INFOT, NOUT, LERR, OK )
*
* DORGLQ
*
SRNAMT = 'DORGLQ'
lapack-netlib/TESTING/LIN/derrqr.f
+1 -26
View File
@@ -77,7 +77,7 @@
* ..
* .. External Subroutines ..
EXTERNAL ALAESM, CHKXER, DGEQR2, DGEQR2P, DGEQRF,
$ DGEQRFP, DGEQRS, DORG2R, DORGQR, DORM2R,
$ DGEQRFP, DORG2R, DORGQR, DORM2R,
$ DORMQR
* ..
* .. Scalars in Common ..
@@ -170,31 +170,6 @@
CALL DGEQR2P( 2, 1, A, 1, B, W, INFO )
CALL CHKXER( 'DGEQR2P', INFOT, NOUT, LERR, OK )
*
* DGEQRS
*
SRNAMT = 'DGEQRS'
INFOT = 1
CALL DGEQRS( -1, 0, 0, A, 1, X, B, 1, W, 1, INFO )
CALL CHKXER( 'DGEQRS', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DGEQRS( 0, -1, 0, A, 1, X, B, 1, W, 1, INFO )
CALL CHKXER( 'DGEQRS', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DGEQRS( 1, 2, 0, A, 2, X, B, 2, W, 1, INFO )
CALL CHKXER( 'DGEQRS', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DGEQRS( 0, 0, -1, A, 1, X, B, 1, W, 1, INFO )
CALL CHKXER( 'DGEQRS', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DGEQRS( 2, 1, 0, A, 1, X, B, 2, W, 1, INFO )
CALL CHKXER( 'DGEQRS', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL DGEQRS( 2, 1, 0, A, 2, X, B, 1, W, 1, INFO )
CALL CHKXER( 'DGEQRS', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL DGEQRS( 1, 1, 2, A, 1, X, B, 1, W, 1, INFO )
CALL CHKXER( 'DGEQRS', INFOT, NOUT, LERR, OK )
*
* DORGQR
*
SRNAMT = 'DORGQR'
lapack-netlib/TESTING/LIN/dgelqs.f
-194
View File
@@ -1,194 +0,0 @@
*> \brief \b DGELQS
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE DGELQS( M, N, NRHS, A, LDA, TAU, B, LDB, WORK, LWORK,
* INFO )
*
* .. Scalar Arguments ..
* INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS
* ..
* .. Array Arguments ..
* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), TAU( * ),
* $ WORK( LWORK )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> Compute a minimum-norm solution
*> min || A*X - B ||
*> using the LQ factorization
*> A = L*Q
*> computed by DGELQF.
*> \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] NRHS
*> \verbatim
*> NRHS is INTEGER
*> The number of columns of B. NRHS >= 0.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is DOUBLE PRECISION array, dimension (LDA,N)
*> Details of the LQ factorization of the original matrix A as
*> returned by DGELQF.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= M.
*> \endverbatim
*>
*> \param[in] TAU
*> \verbatim
*> TAU is DOUBLE PRECISION array, dimension (M)
*> Details of the orthogonal matrix Q.
*> \endverbatim
*>
*> \param[in,out] B
*> \verbatim
*> B is DOUBLE PRECISION array, dimension (LDB,NRHS)
*> On entry, the m-by-nrhs right hand side matrix B.
*> On exit, the n-by-nrhs solution matrix X.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*> LDB is INTEGER
*> The leading dimension of the array B. LDB >= N.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is DOUBLE PRECISION array, dimension (LWORK)
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*> LWORK is INTEGER
*> The length of the array WORK. LWORK must be at least NRHS,
*> and should be at least NRHS*NB, where NB is the block size
*> for this environment.
*> \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.
*
*> \ingroup double_lin
*
* =====================================================================
SUBROUTINE DGELQS( M, N, NRHS, A, LDA, TAU, B, LDB, WORK, LWORK,
$ INFO )
*
* -- LAPACK test routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), B( LDB, * ), TAU( * ),
$ WORK( LWORK )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. External Subroutines ..
EXTERNAL DLASET, DORMLQ, DTRSM, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
IF( M.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.0 .OR. M.GT.N ) THEN
INFO = -2
ELSE IF( NRHS.LT.0 ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -5
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -8
ELSE IF( LWORK.LT.1 .OR. LWORK.LT.NRHS .AND. M.GT.0 .AND. N.GT.0 )
$ THEN
INFO = -10
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DGELQS', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 .OR. NRHS.EQ.0 .OR. M.EQ.0 )
$ RETURN
*
* Solve L*X = B(1:m,:)
*
CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Non-unit', M, NRHS,
$ ONE, A, LDA, B, LDB )
*
* Set B(m+1:n,:) to zero
*
IF( M.LT.N )
$ CALL DLASET( 'Full', N-M, NRHS, ZERO, ZERO, B( M+1, 1 ), LDB )
*
* B := Q' * B
*
CALL DORMLQ( 'Left', 'Transpose', N, NRHS, M, A, LDA, TAU, B, LDB,
$ WORK, LWORK, INFO )
*
RETURN
*
* End of DGELQS
*
END
lapack-netlib/TESTING/LIN/dgeqrs.f
-189
View File
@@ -1,189 +0,0 @@
*> \brief \b DGEQRS
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE DGEQRS( M, N, NRHS, A, LDA, TAU, B, LDB, WORK, LWORK,
* INFO )
*
* .. Scalar Arguments ..
* INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS
* ..
* .. Array Arguments ..
* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), TAU( * ),
* $ WORK( LWORK )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> Solve the least squares problem
*> min || A*X - B ||
*> using the QR factorization
*> A = Q*R
*> computed by DGEQRF.
*> \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] NRHS
*> \verbatim
*> NRHS is INTEGER
*> The number of columns of B. NRHS >= 0.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is DOUBLE PRECISION array, dimension (LDA,N)
*> Details of the QR factorization of the original matrix A as
*> returned by DGEQRF.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= M.
*> \endverbatim
*>
*> \param[in] TAU
*> \verbatim
*> TAU is DOUBLE PRECISION array, dimension (N)
*> Details of the orthogonal matrix Q.
*> \endverbatim
*>
*> \param[in,out] B
*> \verbatim
*> B is DOUBLE PRECISION array, dimension (LDB,NRHS)
*> On entry, the m-by-nrhs right hand side matrix B.
*> On exit, the n-by-nrhs solution matrix X.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*> LDB is INTEGER
*> The leading dimension of the array B. LDB >= M.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is DOUBLE PRECISION array, dimension (LWORK)
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*> LWORK is INTEGER
*> The length of the array WORK. LWORK must be at least NRHS,
*> and should be at least NRHS*NB, where NB is the block size
*> for this environment.
*> \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.
*
*> \ingroup double_lin
*
* =====================================================================
SUBROUTINE DGEQRS( M, N, NRHS, A, LDA, TAU, B, LDB, WORK, LWORK,
$ INFO )
*
* -- LAPACK test routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), B( LDB, * ), TAU( * ),
$ WORK( LWORK )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D+0 )
* ..
* .. External Subroutines ..
EXTERNAL DORMQR, DTRSM, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input arguments.
*
INFO = 0
IF( M.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.0 .OR. N.GT.M ) THEN
INFO = -2
ELSE IF( NRHS.LT.0 ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -5
ELSE IF( LDB.LT.MAX( 1, M ) ) THEN
INFO = -8
ELSE IF( LWORK.LT.1 .OR. LWORK.LT.NRHS .AND. M.GT.0 .AND. N.GT.0 )
$ THEN
INFO = -10
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DGEQRS', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 .OR. NRHS.EQ.0 .OR. M.EQ.0 )
$ RETURN
*
* B := Q' * B
*
CALL DORMQR( 'Left', 'Transpose', M, NRHS, N, A, LDA, TAU, B, LDB,
$ WORK, LWORK, INFO )
*
* Solve R*X = B(1:n,:)
*
CALL DTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', N, NRHS,
$ ONE, A, LDA, B, LDB )
*
RETURN
*
* End of DGEQRS
*
END
lapack-netlib/TESTING/LIN/schklq.f
+13 -7
View File
@@ -235,7 +235,7 @@
REAL RESULT( NTESTS )
* ..
* .. External Subroutines ..
EXTERNAL ALAERH, ALAHD, ALASUM, SERRLQ, SGELQS, SGET02,
EXTERNAL ALAERH, ALAHD, ALASUM, SERRLQ, SGET02,
$ SLACPY, SLARHS, SLATB4, SLATMS, SLQT01, SLQT02,
$ SLQT03, XLAENV
* ..
@@ -370,7 +370,7 @@
$ WORK, LWORK, RWORK, RESULT( 3 ) )
NT = NT + 4
*
* If M>=N and K=N, call SGELQS to solve a system
* If M<=N and K=M, call SGELS to solve a system
* with NRHS right hand sides and compute the
* residual.
*
@@ -387,14 +387,20 @@
*
CALL SLACPY( 'Full', M, NRHS, B, LDA, X,
$ LDA )
SRNAMT = 'SGELQS'
CALL SGELQS( M, N, NRHS, AF, LDA, TAU, X,
$ LDA, WORK, LWORK, INFO )
*
* Check error code from SGELQS.
* Reset AF to the original matrix. SGELS
* factors the matrix before solving the system.
*
CALL SLACPY( 'Full', M, N, A, LDA, AF, LDA )
*
SRNAMT = 'SGELS'
CALL SGELS( 'No transpose', M, N, NRHS, AF,
$ LDA, X, LDA, WORK, LWORK, INFO )
*
* Check error code from SGELS.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'SGELQS', INFO, 0, ' ',
$ CALL ALAERH( PATH, 'SGELS', INFO, 0, 'N',
$ M, N, NRHS, -1, NB, IMAT,
$ NFAIL, NERRS, NOUT )
*
lapack-netlib/TESTING/LIN/schkqr.f
+13 -7
View File
@@ -244,7 +244,7 @@
EXTERNAL SGENND
* ..
* .. External Subroutines ..
EXTERNAL ALAERH, ALAHD, ALASUM, SERRQR, SGEQRS, SGET02,
EXTERNAL ALAERH, ALAHD, ALASUM, SERRQR, SGELS, SGET02,
$ SLACPY, SLARHS, SLATB4, SLATMS, SQRT01,
$ SQRT01P, SQRT02, SQRT03, XLAENV
* ..
@@ -388,7 +388,7 @@
$ WORK, LWORK, RWORK, RESULT( 3 ) )
NT = NT + 4
*
* If M>=N and K=N, call SGEQRS to solve a system
* If M>=N and K=N, call SGELS to solve a system
* with NRHS right hand sides and compute the
* residual.
*
@@ -405,14 +405,20 @@
*
CALL SLACPY( 'Full', M, NRHS, B, LDA, X,
$ LDA )
SRNAMT = 'SGEQRS'
CALL SGEQRS( M, N, NRHS, AF, LDA, TAU, X,
$ LDA, WORK, LWORK, INFO )
*
* Check error code from SGEQRS.
* Reset AF to the original matrix. SGELS
* factors the matrix before solving the system.
*
CALL SLACPY( 'Full', M, N, A, LDA, AF, LDA )
*
SRNAMT = 'SGELS'
CALL SGELS( 'No transpose', M, N, NRHS, AF,
$ LDA, X, LDA, WORK, LWORK, INFO )
*
* Check error code from SGELS.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'SGEQRS', INFO, 0, ' ',
$ CALL ALAERH( PATH, 'SGELS', INFO, 0, 'N',
$ M, N, NRHS, -1, NB, IMAT,
$ NFAIL, NERRS, NOUT )
*
lapack-netlib/TESTING/LIN/serrlq.f
+1 -26
View File
@@ -76,7 +76,7 @@
$ W( NMAX ), X( NMAX )
* ..
* .. External Subroutines ..
EXTERNAL ALAESM, CHKXER, SGELQ2, SGELQF, SGELQS, SORGL2,
EXTERNAL ALAESM, CHKXER, SGELQ2, SGELQF, SORGL2,
$ SORGLQ, SORML2, SORMLQ
* ..
* .. Scalars in Common ..
@@ -140,31 +140,6 @@
CALL SGELQ2( 2, 1, A, 1, B, W, INFO )
CALL CHKXER( 'SGELQ2', INFOT, NOUT, LERR, OK )
*
* SGELQS
*
SRNAMT = 'SGELQS'
INFOT = 1
CALL SGELQS( -1, 0, 0, A, 1, X, B, 1, W, 1, INFO )
CALL CHKXER( 'SGELQS', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SGELQS( 0, -1, 0, A, 1, X, B, 1, W, 1, INFO )
CALL CHKXER( 'SGELQS', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SGELQS( 2, 1, 0, A, 2, X, B, 1, W, 1, INFO )
CALL CHKXER( 'SGELQS', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SGELQS( 0, 0, -1, A, 1, X, B, 1, W, 1, INFO )
CALL CHKXER( 'SGELQS', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SGELQS( 2, 2, 0, A, 1, X, B, 2, W, 1, INFO )
CALL CHKXER( 'SGELQS', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL SGELQS( 1, 2, 0, A, 1, X, B, 1, W, 1, INFO )
CALL CHKXER( 'SGELQS', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL SGELQS( 1, 1, 2, A, 1, X, B, 1, W, 1, INFO )
CALL CHKXER( 'SGELQS', INFOT, NOUT, LERR, OK )
*
* SORGLQ
*
SRNAMT = 'SORGLQ'
lapack-netlib/TESTING/LIN/serrqr.f
+1 -26
View File
@@ -77,7 +77,7 @@
* ..
* .. External Subroutines ..
EXTERNAL ALAESM, CHKXER, SGEQR2, SGEQR2P, SGEQRF,
$ SGEQRFP, SGEQRS, SORG2R, SORGQR, SORM2R,
$ SGEQRFP, SORG2R, SORGQR, SORM2R,
$ SORMQR
* ..
* .. Scalars in Common ..
@@ -170,31 +170,6 @@
CALL SGEQR2P( 2, 1, A, 1, B, W, INFO )
CALL CHKXER( 'SGEQR2P', INFOT, NOUT, LERR, OK )
*
* SGEQRS
*
SRNAMT = 'SGEQRS'
INFOT = 1
CALL SGEQRS( -1, 0, 0, A, 1, X, B, 1, W, 1, INFO )
CALL CHKXER( 'SGEQRS', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SGEQRS( 0, -1, 0, A, 1, X, B, 1, W, 1, INFO )
CALL CHKXER( 'SGEQRS', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SGEQRS( 1, 2, 0, A, 2, X, B, 2, W, 1, INFO )
CALL CHKXER( 'SGEQRS', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SGEQRS( 0, 0, -1, A, 1, X, B, 1, W, 1, INFO )
CALL CHKXER( 'SGEQRS', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SGEQRS( 2, 1, 0, A, 1, X, B, 2, W, 1, INFO )
CALL CHKXER( 'SGEQRS', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL SGEQRS( 2, 1, 0, A, 2, X, B, 1, W, 1, INFO )
CALL CHKXER( 'SGEQRS', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL SGEQRS( 1, 1, 2, A, 1, X, B, 1, W, 1, INFO )
CALL CHKXER( 'SGEQRS', INFOT, NOUT, LERR, OK )
*
* SORGQR
*
SRNAMT = 'SORGQR'
lapack-netlib/TESTING/LIN/sgelqs.f
-194
View File
@@ -1,194 +0,0 @@
*> \brief \b SGELQS
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE SGELQS( M, N, NRHS, A, LDA, TAU, B, LDB, WORK, LWORK,
* INFO )
*
* .. Scalar Arguments ..
* INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS
* ..
* .. Array Arguments ..
* REAL A( LDA, * ), B( LDB, * ), TAU( * ),
* $ WORK( LWORK )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> Compute a minimum-norm solution
*> min || A*X - B ||
*> using the LQ factorization
*> A = L*Q
*> computed by SGELQF.
*> \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] NRHS
*> \verbatim
*> NRHS is INTEGER
*> The number of columns of B. NRHS >= 0.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is REAL array, dimension (LDA,N)
*> Details of the LQ factorization of the original matrix A as
*> returned by SGELQF.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= M.
*> \endverbatim
*>
*> \param[in] TAU
*> \verbatim
*> TAU is REAL array, dimension (M)
*> Details of the orthogonal matrix Q.
*> \endverbatim
*>
*> \param[in,out] B
*> \verbatim
*> B is REAL array, dimension (LDB,NRHS)
*> On entry, the m-by-nrhs right hand side matrix B.
*> On exit, the n-by-nrhs solution matrix X.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*> LDB is INTEGER
*> The leading dimension of the array B. LDB >= N.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is REAL array, dimension (LWORK)
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*> LWORK is INTEGER
*> The length of the array WORK. LWORK must be at least NRHS,
*> and should be at least NRHS*NB, where NB is the block size
*> for this environment.
*> \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.
*
*> \ingroup single_lin
*
* =====================================================================
SUBROUTINE SGELQS( M, N, NRHS, A, LDA, TAU, B, LDB, WORK, LWORK,
$ INFO )
*
* -- LAPACK test routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS
* ..
* .. Array Arguments ..
REAL A( LDA, * ), B( LDB, * ), TAU( * ),
$ WORK( LWORK )
* ..
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. External Subroutines ..
EXTERNAL SLASET, SORMLQ, STRSM, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
IF( M.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.0 .OR. M.GT.N ) THEN
INFO = -2
ELSE IF( NRHS.LT.0 ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -5
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -8
ELSE IF( LWORK.LT.1 .OR. LWORK.LT.NRHS .AND. M.GT.0 .AND. N.GT.0 )
$ THEN
INFO = -10
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SGELQS', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 .OR. NRHS.EQ.0 .OR. M.EQ.0 )
$ RETURN
*
* Solve L*X = B(1:m,:)
*
CALL STRSM( 'Left', 'Lower', 'No transpose', 'Non-unit', M, NRHS,
$ ONE, A, LDA, B, LDB )
*
* Set B(m+1:n,:) to zero
*
IF( M.LT.N )
$ CALL SLASET( 'Full', N-M, NRHS, ZERO, ZERO, B( M+1, 1 ), LDB )
*
* B := Q' * B
*
CALL SORMLQ( 'Left', 'Transpose', N, NRHS, M, A, LDA, TAU, B, LDB,
$ WORK, LWORK, INFO )
*
RETURN
*
* End of SGELQS
*
END
lapack-netlib/TESTING/LIN/sgeqrs.f
-189
View File
@@ -1,189 +0,0 @@
*> \brief \b SGEQRS
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE SGEQRS( M, N, NRHS, A, LDA, TAU, B, LDB, WORK, LWORK,
* INFO )
*
* .. Scalar Arguments ..
* INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS
* ..
* .. Array Arguments ..
* REAL A( LDA, * ), B( LDB, * ), TAU( * ),
* $ WORK( LWORK )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> Solve the least squares problem
*> min || A*X - B ||
*> using the QR factorization
*> A = Q*R
*> computed by SGEQRF.
*> \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] NRHS
*> \verbatim
*> NRHS is INTEGER
*> The number of columns of B. NRHS >= 0.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is REAL array, dimension (LDA,N)
*> Details of the QR factorization of the original matrix A as
*> returned by SGEQRF.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= M.
*> \endverbatim
*>
*> \param[in] TAU
*> \verbatim
*> TAU is REAL array, dimension (N)
*> Details of the orthogonal matrix Q.
*> \endverbatim
*>
*> \param[in,out] B
*> \verbatim
*> B is REAL array, dimension (LDB,NRHS)
*> On entry, the m-by-nrhs right hand side matrix B.
*> On exit, the n-by-nrhs solution matrix X.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*> LDB is INTEGER
*> The leading dimension of the array B. LDB >= M.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is REAL array, dimension (LWORK)
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*> LWORK is INTEGER
*> The length of the array WORK. LWORK must be at least NRHS,
*> and should be at least NRHS*NB, where NB is the block size
*> for this environment.
*> \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.
*
*> \ingroup single_lin
*
* =====================================================================
SUBROUTINE SGEQRS( M, N, NRHS, A, LDA, TAU, B, LDB, WORK, LWORK,
$ INFO )
*
* -- LAPACK test routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS
* ..
* .. Array Arguments ..
REAL A( LDA, * ), B( LDB, * ), TAU( * ),
$ WORK( LWORK )
* ..
*
* =====================================================================
*
* .. Parameters ..
REAL ONE
PARAMETER ( ONE = 1.0E+0 )
* ..
* .. External Subroutines ..
EXTERNAL SORMQR, STRSM, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input arguments.
*
INFO = 0
IF( M.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.0 .OR. N.GT.M ) THEN
INFO = -2
ELSE IF( NRHS.LT.0 ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -5
ELSE IF( LDB.LT.MAX( 1, M ) ) THEN
INFO = -8
ELSE IF( LWORK.LT.1 .OR. LWORK.LT.NRHS .AND. M.GT.0 .AND. N.GT.0 )
$ THEN
INFO = -10
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SGEQRS', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 .OR. NRHS.EQ.0 .OR. M.EQ.0 )
$ RETURN
*
* B := Q' * B
*
CALL SORMQR( 'Left', 'Transpose', M, NRHS, N, A, LDA, TAU, B, LDB,
$ WORK, LWORK, INFO )
*
* Solve R*X = B(1:n,:)
*
CALL STRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', N, NRHS,
$ ONE, A, LDA, B, LDB )
*
RETURN
*
* End of SGEQRS
*
END
lapack-netlib/TESTING/LIN/zchklq.f
+13 -7
View File
@@ -235,7 +235,7 @@
DOUBLE PRECISION RESULT( NTESTS )
* ..
* .. External Subroutines ..
EXTERNAL ALAERH, ALAHD, ALASUM, XLAENV, ZERRLQ, ZGELQS,
EXTERNAL ALAERH, ALAHD, ALASUM, XLAENV, ZERRLQ, ZGELS,
$ ZGET02, ZLACPY, ZLARHS, ZLATB4, ZLATMS, ZLQT01,
$ ZLQT02, ZLQT03
* ..
@@ -370,7 +370,7 @@
$ WORK, LWORK, RWORK, RESULT( 3 ) )
NT = NT + 4
*
* If M>=N and K=N, call ZGELQS to solve a system
* If M<=N and K=M, call ZGELS to solve a system
* with NRHS right hand sides and compute the
* residual.
*
@@ -387,14 +387,20 @@
*
CALL ZLACPY( 'Full', M, NRHS, B, LDA, X,
$ LDA )
SRNAMT = 'ZGELQS'
CALL ZGELQS( M, N, NRHS, AF, LDA, TAU, X,
$ LDA, WORK, LWORK, INFO )
*
* Check error code from ZGELQS.
* Reset AF to the original matrix. ZGELS
* factors the matrix before solving the system.
*
CALL ZLACPY( 'Full', M, N, A, LDA, AF, LDA )
*
SRNAMT = 'ZGELS'
CALL ZGELS( 'No transpose', M, N, NRHS, AF,
$ LDA, X, LDA, WORK, LWORK, INFO )
*
* Check error code from ZGELS.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'ZGELQS', INFO, 0, ' ',
$ CALL ALAERH( PATH, 'ZGELS', INFO, 0, 'N',
$ M, N, NRHS, -1, NB, IMAT,
$ NFAIL, NERRS, NOUT )
*
lapack-netlib/TESTING/LIN/zchkqr.f
+13 -7
View File
@@ -244,7 +244,7 @@
EXTERNAL ZGENND
* ..
* .. External Subroutines ..
EXTERNAL ALAERH, ALAHD, ALASUM, XLAENV, ZERRQR, ZGEQRS,
EXTERNAL ALAERH, ALAHD, ALASUM, XLAENV, ZERRQR, ZGELS,
$ ZGET02, ZLACPY, ZLARHS, ZLATB4, ZLATMS, ZQRT01,
$ ZQRT01P, ZQRT02, ZQRT03
* ..
@@ -388,7 +388,7 @@
$ WORK, LWORK, RWORK, RESULT( 3 ) )
NT = NT + 4
*
* If M>=N and K=N, call ZGEQRS to solve a system
* If M>=N and K=N, call ZGELS to solve a system
* with NRHS right hand sides and compute the
* residual.
*
@@ -405,14 +405,20 @@
*
CALL ZLACPY( 'Full', M, NRHS, B, LDA, X,
$ LDA )
SRNAMT = 'ZGEQRS'
CALL ZGEQRS( M, N, NRHS, AF, LDA, TAU, X,
$ LDA, WORK, LWORK, INFO )
*
* Check error code from ZGEQRS.
* Reset AF to the original matrix. ZGELS
* factors the matrix before solving the system.
*
CALL ZLACPY( 'Full', M, N, A, LDA, AF, LDA )
*
SRNAMT = 'ZGELS'
CALL ZGELS( 'No transpose', M, N, NRHS, AF,
$ LDA, X, LDA, WORK, LWORK, INFO )
*
* Check error code from ZGELS.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'ZGEQRS', INFO, 0, ' ',
$ CALL ALAERH( PATH, 'ZGELS', INFO, 0, 'N',
$ M, N, NRHS, -1, NB, IMAT,
$ NFAIL, NERRS, NOUT )
*
lapack-netlib/TESTING/LIN/zerrlq.f
+1 -26
View File
@@ -76,7 +76,7 @@
$ W( NMAX ), X( NMAX )
* ..
* .. External Subroutines ..
EXTERNAL ALAESM, CHKXER, ZGELQ2, ZGELQF, ZGELQS, ZUNGL2,
EXTERNAL ALAESM, CHKXER, ZGELQ2, ZGELQF, ZUNGL2,
$ ZUNGLQ, ZUNML2, ZUNMLQ
* ..
* .. Scalars in Common ..
@@ -142,31 +142,6 @@
CALL ZGELQ2( 2, 1, A, 1, B, W, INFO )
CALL CHKXER( 'ZGELQ2', INFOT, NOUT, LERR, OK )
*
* ZGELQS
*
SRNAMT = 'ZGELQS'
INFOT = 1
CALL ZGELQS( -1, 0, 0, A, 1, X, B, 1, W, 1, INFO )
CALL CHKXER( 'ZGELQS', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL ZGELQS( 0, -1, 0, A, 1, X, B, 1, W, 1, INFO )
CALL CHKXER( 'ZGELQS', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL ZGELQS( 2, 1, 0, A, 2, X, B, 1, W, 1, INFO )
CALL CHKXER( 'ZGELQS', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL ZGELQS( 0, 0, -1, A, 1, X, B, 1, W, 1, INFO )
CALL CHKXER( 'ZGELQS', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL ZGELQS( 2, 2, 0, A, 1, X, B, 2, W, 1, INFO )
CALL CHKXER( 'ZGELQS', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL ZGELQS( 1, 2, 0, A, 1, X, B, 1, W, 1, INFO )
CALL CHKXER( 'ZGELQS', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL ZGELQS( 1, 1, 2, A, 1, X, B, 1, W, 1, INFO )
CALL CHKXER( 'ZGELQS', INFOT, NOUT, LERR, OK )
*
* ZUNGLQ
*
SRNAMT = 'ZUNGLQ'
lapack-netlib/TESTING/LIN/zerrqr.f
+1 -26
View File
@@ -77,7 +77,7 @@
* ..
* .. External Subroutines ..
EXTERNAL ALAESM, CHKXER, ZGEQR2, ZGEQR2P, ZGEQRF,
$ ZGEQRFP, ZGEQRS, ZUNG2R, ZUNGQR, ZUNM2R,
$ ZGEQRFP, ZUNG2R, ZUNGQR, ZUNM2R,
$ ZUNMQR
* ..
* .. Scalars in Common ..
@@ -172,31 +172,6 @@
CALL ZGEQR2P( 2, 1, A, 1, B, W, INFO )
CALL CHKXER( 'ZGEQR2P', INFOT, NOUT, LERR, OK )
*
* ZGEQRS
*
SRNAMT = 'ZGEQRS'
INFOT = 1
CALL ZGEQRS( -1, 0, 0, A, 1, X, B, 1, W, 1, INFO )
CALL CHKXER( 'ZGEQRS', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL ZGEQRS( 0, -1, 0, A, 1, X, B, 1, W, 1, INFO )
CALL CHKXER( 'ZGEQRS', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL ZGEQRS( 1, 2, 0, A, 2, X, B, 2, W, 1, INFO )
CALL CHKXER( 'ZGEQRS', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL ZGEQRS( 0, 0, -1, A, 1, X, B, 1, W, 1, INFO )
CALL CHKXER( 'ZGEQRS', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL ZGEQRS( 2, 1, 0, A, 1, X, B, 2, W, 1, INFO )
CALL CHKXER( 'ZGEQRS', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL ZGEQRS( 2, 1, 0, A, 2, X, B, 1, W, 1, INFO )
CALL CHKXER( 'ZGEQRS', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL ZGEQRS( 1, 1, 2, A, 1, X, B, 1, W, 1, INFO )
CALL CHKXER( 'ZGEQRS', INFOT, NOUT, LERR, OK )
*
* ZUNGQR
*
SRNAMT = 'ZUNGQR'
lapack-netlib/TESTING/LIN/zgelqs.f
-196
View File
@@ -1,196 +0,0 @@
*> \brief \b ZGELQS
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE ZGELQS( M, N, NRHS, A, LDA, TAU, B, LDB, WORK, LWORK,
* INFO )
*
* .. Scalar Arguments ..
* INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS
* ..
* .. Array Arguments ..
* COMPLEX*16 A( LDA, * ), B( LDB, * ), TAU( * ),
* $ WORK( LWORK )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> Compute a minimum-norm solution
*> min || A*X - B ||
*> using the LQ factorization
*> A = L*Q
*> computed by ZGELQF.
*> \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] NRHS
*> \verbatim
*> NRHS is INTEGER
*> The number of columns of B. NRHS >= 0.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> Details of the LQ factorization of the original matrix A as
*> returned by ZGELQF.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= M.
*> \endverbatim
*>
*> \param[in] TAU
*> \verbatim
*> TAU is COMPLEX*16 array, dimension (M)
*> Details of the orthogonal matrix Q.
*> \endverbatim
*>
*> \param[in,out] B
*> \verbatim
*> B is COMPLEX*16 array, dimension (LDB,NRHS)
*> On entry, the m-by-nrhs right hand side matrix B.
*> On exit, the n-by-nrhs solution matrix X.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*> LDB is INTEGER
*> The leading dimension of the array B. LDB >= N.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension (LWORK)
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*> LWORK is INTEGER
*> The length of the array WORK. LWORK must be at least NRHS,
*> and should be at least NRHS*NB, where NB is the block size
*> for this environment.
*> \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.
*
*> \ingroup complex16_lin
*
* =====================================================================
SUBROUTINE ZGELQS( M, N, NRHS, A, LDA, TAU, B, LDB, WORK, LWORK,
$ INFO )
*
* -- LAPACK test routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * ), B( LDB, * ), TAU( * ),
$ WORK( LWORK )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 CZERO, CONE
PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ),
$ CONE = ( 1.0D+0, 0.0D+0 ) )
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZLASET, ZTRSM, ZUNMLQ
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
IF( M.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.0 .OR. M.GT.N ) THEN
INFO = -2
ELSE IF( NRHS.LT.0 ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -5
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -8
ELSE IF( LWORK.LT.1 .OR. LWORK.LT.NRHS .AND. M.GT.0 .AND. N.GT.0 )
$ THEN
INFO = -10
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZGELQS', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 .OR. NRHS.EQ.0 .OR. M.EQ.0 )
$ RETURN
*
* Solve L*X = B(1:m,:)
*
CALL ZTRSM( 'Left', 'Lower', 'No transpose', 'Non-unit', M, NRHS,
$ CONE, A, LDA, B, LDB )
*
* Set B(m+1:n,:) to zero
*
IF( M.LT.N )
$ CALL ZLASET( 'Full', N-M, NRHS, CZERO, CZERO, B( M+1, 1 ),
$ LDB )
*
* B := Q' * B
*
CALL ZUNMLQ( 'Left', 'Conjugate transpose', N, NRHS, M, A, LDA,
$ TAU, B, LDB, WORK, LWORK, INFO )
*
RETURN
*
* End of ZGELQS
*
END
lapack-netlib/TESTING/LIN/zgeqrs.f
-189
View File
@@ -1,189 +0,0 @@
*> \brief \b ZGEQRS
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE ZGEQRS( M, N, NRHS, A, LDA, TAU, B, LDB, WORK, LWORK,
* INFO )
*
* .. Scalar Arguments ..
* INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS
* ..
* .. Array Arguments ..
* COMPLEX*16 A( LDA, * ), B( LDB, * ), TAU( * ),
* $ WORK( LWORK )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> Solve the least squares problem
*> min || A*X - B ||
*> using the QR factorization
*> A = Q*R
*> computed by ZGEQRF.
*> \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] NRHS
*> \verbatim
*> NRHS is INTEGER
*> The number of columns of B. NRHS >= 0.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> Details of the QR factorization of the original matrix A as
*> returned by ZGEQRF.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= M.
*> \endverbatim
*>
*> \param[in] TAU
*> \verbatim
*> TAU is COMPLEX*16 array, dimension (N)
*> Details of the orthogonal matrix Q.
*> \endverbatim
*>
*> \param[in,out] B
*> \verbatim
*> B is COMPLEX*16 array, dimension (LDB,NRHS)
*> On entry, the m-by-nrhs right hand side matrix B.
*> On exit, the n-by-nrhs solution matrix X.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*> LDB is INTEGER
*> The leading dimension of the array B. LDB >= M.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension (LWORK)
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*> LWORK is INTEGER
*> The length of the array WORK. LWORK must be at least NRHS,
*> and should be at least NRHS*NB, where NB is the block size
*> for this environment.
*> \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.
*
*> \ingroup complex16_lin
*
* =====================================================================
SUBROUTINE ZGEQRS( M, N, NRHS, A, LDA, TAU, B, LDB, WORK, LWORK,
$ INFO )
*
* -- LAPACK test routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * ), B( LDB, * ), TAU( * ),
$ WORK( LWORK )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ONE
PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) )
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZTRSM, ZUNMQR
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input arguments.
*
INFO = 0
IF( M.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.0 .OR. N.GT.M ) THEN
INFO = -2
ELSE IF( NRHS.LT.0 ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -5
ELSE IF( LDB.LT.MAX( 1, M ) ) THEN
INFO = -8
ELSE IF( LWORK.LT.1 .OR. LWORK.LT.NRHS .AND. M.GT.0 .AND. N.GT.0 )
$ THEN
INFO = -10
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZGEQRS', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 .OR. NRHS.EQ.0 .OR. M.EQ.0 )
$ RETURN
*
* B := Q' * B
*
CALL ZUNMQR( 'Left', 'Conjugate transpose', M, NRHS, N, A, LDA,
$ TAU, B, LDB, WORK, LWORK, INFO )
*
* Solve R*X = B(1:n,:)
*
CALL ZTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', N, NRHS,
$ ONE, A, LDA, B, LDB )
*
RETURN
*
* End of ZGEQRS
*
END