diff options
| author | philippe.theveny <philippe.theveny@8a072113-8704-0410-8d35-dd094bca7971> | 2015-08-06 17:56:35 +0000 |
|---|---|---|
| committer | philippe.theveny <philippe.theveny@8a072113-8704-0410-8d35-dd094bca7971> | 2015-08-06 17:56:35 +0000 |
| commit | f6dc581dc61092618ae23fc4640d37e5366191b5 (patch) | |
| tree | 61fad508ce3ed846edeb4f815b73bcdabaa1f793 /TESTING/LIN | |
| parent | fcfe82e566e8c9424346a0f3923bc7d829b2d750 (diff) | |
| download | lapack-f6dc581dc61092618ae23fc4640d37e5366191b5.tar.gz lapack-f6dc581dc61092618ae23fc4640d37e5366191b5.tar.bz2 lapack-f6dc581dc61092618ae23fc4640d37e5366191b5.zip | |
Remove all but one deprecated routines from the test suite.
NOTE: The tests are renumbered in xDRVLS and xCHKTZ.
TODO: remove deprecated xGEQPF, when it is replaced by xGEQP3 in xGGSVP.
Diffstat (limited to 'TESTING/LIN')
| -rw-r--r-- | TESTING/LIN/CMakeLists.txt | 8 | ||||
| -rw-r--r-- | TESTING/LIN/Makefile | 8 | ||||
| -rw-r--r-- | TESTING/LIN/alahd.f | 16 | ||||
| -rw-r--r-- | TESTING/LIN/cchktz.f | 67 | ||||
| -rw-r--r-- | TESTING/LIN/cdrvls.f | 149 | ||||
| -rw-r--r-- | TESTING/LIN/cerrls.f | 29 | ||||
| -rw-r--r-- | TESTING/LIN/cerrtz.f | 17 | ||||
| -rw-r--r-- | TESTING/LIN/ctzt01.f | 187 | ||||
| -rw-r--r-- | TESTING/LIN/ctzt02.f | 173 | ||||
| -rw-r--r-- | TESTING/LIN/dchktz.f | 66 | ||||
| -rw-r--r-- | TESTING/LIN/ddrvls.f | 158 | ||||
| -rw-r--r-- | TESTING/LIN/derrls.f | 24 | ||||
| -rw-r--r-- | TESTING/LIN/derrtz.f | 17 | ||||
| -rw-r--r-- | TESTING/LIN/dtzt01.f | 186 | ||||
| -rw-r--r-- | TESTING/LIN/dtzt02.f | 172 | ||||
| -rw-r--r-- | TESTING/LIN/schktz.f | 66 | ||||
| -rw-r--r-- | TESTING/LIN/sdrvls.f | 158 | ||||
| -rw-r--r-- | TESTING/LIN/serrls.f | 24 | ||||
| -rw-r--r-- | TESTING/LIN/serrtz.f | 17 | ||||
| -rw-r--r-- | TESTING/LIN/stzt01.f | 186 | ||||
| -rw-r--r-- | TESTING/LIN/stzt02.f | 172 | ||||
| -rw-r--r-- | TESTING/LIN/zchktz.f | 67 | ||||
| -rw-r--r-- | TESTING/LIN/zdrvls.f | 157 | ||||
| -rw-r--r-- | TESTING/LIN/zerrls.f | 29 | ||||
| -rw-r--r-- | TESTING/LIN/zerrtz.f | 17 | ||||
| -rw-r--r-- | TESTING/LIN/ztzt01.f | 188 | ||||
| -rw-r--r-- | TESTING/LIN/ztzt02.f | 174 |
27 files changed, 237 insertions, 2295 deletions
diff --git a/TESTING/LIN/CMakeLists.txt b/TESTING/LIN/CMakeLists.txt index d7fb8625..2fc14e61 100644 --- a/TESTING/LIN/CMakeLists.txt +++ b/TESTING/LIN/CMakeLists.txt @@ -33,7 +33,7 @@ set(SLINTST schkaa.f stbt02.f stbt03.f stbt05.f stbt06.f stpt01.f stpt02.f stpt03.f stpt05.f stpt06.f strt01.f strt02.f strt03.f strt05.f strt06.f - stzt01.f stzt02.f sgennd.f + sgennd.f sqrt04.f sqrt05.f schkqrt.f serrqrt.f schkqrtp.f serrqrtp.f) if(USEXBLAS) @@ -73,7 +73,7 @@ set(CLINTST cchkaa.f ctbt02.f ctbt03.f ctbt05.f ctbt06.f ctpt01.f ctpt02.f ctpt03.f ctpt05.f ctpt06.f ctrt01.f ctrt02.f ctrt03.f ctrt05.f ctrt06.f - ctzt01.f ctzt02.f sget06.f cgennd.f + sget06.f cgennd.f cqrt04.f cqrt05.f cchkqrt.f cerrqrt.f cchkqrtp.f cerrqrtp.f ) if(USEXBLAS) @@ -110,7 +110,7 @@ set(DLINTST dchkaa.f dtbt02.f dtbt03.f dtbt05.f dtbt06.f dtpt01.f dtpt02.f dtpt03.f dtpt05.f dtpt06.f dtrt01.f dtrt02.f dtrt03.f dtrt05.f dtrt06.f - dtzt01.f dtzt02.f dgennd.f + dgennd.f dqrt04.f dqrt05.f dchkqrt.f derrqrt.f dchkqrtp.f derrqrtp.f ) if(USEXBLAS) @@ -152,7 +152,7 @@ set(ZLINTST zchkaa.f ztbt02.f ztbt03.f ztbt05.f ztbt06.f ztpt01.f ztpt02.f ztpt03.f ztpt05.f ztpt06.f ztrt01.f ztrt02.f ztrt03.f ztrt05.f ztrt06.f - ztzt01.f ztzt02.f dget06.f zgennd.f + dget06.f zgennd.f zqrt04.f zqrt05.f zchkqrt.f zerrqrt.f zchkqrtp.f zerrqrtp.f ) if(USEXBLAS) diff --git a/TESTING/LIN/Makefile b/TESTING/LIN/Makefile index 3eb968fd..32e65f93 100644 --- a/TESTING/LIN/Makefile +++ b/TESTING/LIN/Makefile @@ -74,7 +74,7 @@ SLINTST = schkaa.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 \ - stzt01.o stzt02.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 ifdef USEXBLAS SLINTST += serrvxx.o sdrvgex.o sdrvsyx.o serrgex.o sdrvgbx.o sdrvpox.o \ @@ -114,7 +114,7 @@ CLINTST = cchkaa.o \ ctbt02.o ctbt03.o ctbt05.o ctbt06.o ctpt01.o \ ctpt02.o ctpt03.o ctpt05.o ctpt06.o ctrt01.o \ ctrt02.o ctrt03.o ctrt05.o ctrt06.o \ - ctzt01.o ctzt02.o sget06.o cgennd.o \ + sget06.o cgennd.o \ cqrt04.o cqrt05.o cchkqrt.o cerrqrt.o cchkqrtp.o cerrqrtp.o ifdef USEXBLAS @@ -152,7 +152,7 @@ DLINTST = dchkaa.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 \ - dtzt01.o dtzt02.o dgennd.o \ + dgennd.o \ dqrt04.o dqrt05.o dchkqrt.o derrqrt.o dchkqrtp.o derrqrtp.o ifdef USEXBLAS @@ -193,7 +193,7 @@ ZLINTST = zchkaa.o \ ztbt02.o ztbt03.o ztbt05.o ztbt06.o ztpt01.o \ ztpt02.o ztpt03.o ztpt05.o ztpt06.o ztrt01.o \ ztrt02.o ztrt03.o ztrt05.o ztrt06.o \ - ztzt01.o ztzt02.o dget06.o zgennd.o \ + dget06.o zgennd.o \ zqrt04.o zqrt05.o zchkqrt.o zerrqrt.o zchkqrtp.o zerrqrtp.o ifdef USEXBLAS diff --git a/TESTING/LIN/alahd.f b/TESTING/LIN/alahd.f index c501ac75..b09922ba 100644 --- a/TESTING/LIN/alahd.f +++ b/TESTING/LIN/alahd.f @@ -553,14 +553,11 @@ * WRITE( IOUNIT, FMT = 9985 )PATH WRITE( IOUNIT, FMT = 9968 ) - WRITE( IOUNIT, FMT = 9929 )C1, C1 + WRITE( IOUNIT, FMT = 9929 )C1 WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' ) WRITE( IOUNIT, FMT = 9940 )1 WRITE( IOUNIT, FMT = 9937 )2 WRITE( IOUNIT, FMT = 9938 )3 - WRITE( IOUNIT, FMT = 9940 )4 - WRITE( IOUNIT, FMT = 9937 )5 - WRITE( IOUNIT, FMT = 9938 )6 WRITE( IOUNIT, FMT = '( '' Messages:'' )' ) * ELSE IF( LSAMEN( 2, P2, 'LS' ) ) THEN @@ -570,7 +567,7 @@ * WRITE( IOUNIT, FMT = 9984 )PATH WRITE( IOUNIT, FMT = 9967 ) - WRITE( IOUNIT, FMT = 9921 )C1, C1, C1, C1, C1 + WRITE( IOUNIT, FMT = 9921 )C1, C1, C1, C1 WRITE( IOUNIT, FMT = 9935 )1 WRITE( IOUNIT, FMT = 9931 )2 WRITE( IOUNIT, FMT = 9933 )3 @@ -946,13 +943,10 @@ $ 'otherwise', / 7X, $ 'check if X is in the row space of A or A'' ', $ '(overdetermined case)' ) - 9929 FORMAT( ' Test ratios (1-3: ', A1, 'TZRQF, 4-6: ', A1, - $ 'TZRZF):' ) - 9920 FORMAT( 3X, ' 7-10: same as 3-6', 3X, ' 11-14: same as 3-6', - $ 3X, ' 15-18: same as 3-6' ) + 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, - $ 'GELSX, 7-10: ', A1, 'GELSY, 11-14: ', A1, 'GELSS, 15-18: ', - $ A1, 'GELSD)' ) + $ 'GELSY, 7-10: ', A1, 'GELSS, 11-14: ', A1, 'GELSD)' ) 9928 FORMAT( 7X, 'where ALPHA = ( 1 + SQRT( 17 ) ) / 8' ) 9927 FORMAT( 3X, I2, ': ABS( Largest element in L )', / 12X, $ ' - ( 1 / ( 1 - ALPHA ) ) + THRESH' ) diff --git a/TESTING/LIN/cchktz.f b/TESTING/LIN/cchktz.f index f7be0155..dbba5421 100644 --- a/TESTING/LIN/cchktz.f +++ b/TESTING/LIN/cchktz.f @@ -29,7 +29,7 @@ *> *> \verbatim *> -*> CCHKTZ tests CTZRQF and CTZRZF. +*> CCHKTZ tests CTZRZF. *> \endverbatim * * Arguments: @@ -160,7 +160,7 @@ INTEGER NTYPES PARAMETER ( NTYPES = 3 ) INTEGER NTESTS - PARAMETER ( NTESTS = 6 ) + PARAMETER ( NTESTS = 3 ) REAL ONE, ZERO PARAMETER ( ONE = 1.0E0, ZERO = 0.0E0 ) * .. @@ -175,12 +175,12 @@ REAL RESULT( NTESTS ) * .. * .. External Functions .. - REAL CQRT12, CRZT01, CRZT02, CTZT01, CTZT02, SLAMCH - EXTERNAL CQRT12, CRZT01, CRZT02, CTZT01, CTZT02, SLAMCH + REAL CQRT12, CRZT01, CRZT02, SLAMCH + EXTERNAL CQRT12, CRZT01, CRZT02, SLAMCH * .. * .. External Subroutines .. EXTERNAL ALAHD, ALASUM, CERRTZ, CGEQR2, CLACPY, CLASET, - $ CLATMS, CTZRQF, CTZRZF, SLAORD + $ CLATMS, CTZRZF, SLAORD * .. * .. Intrinsic Functions .. INTRINSIC CMPLX, MAX, MIN @@ -244,53 +244,6 @@ * MODE = IMODE - 1 * -* Test CTZRQF -* -* Generate test matrix of size m by n using -* singular value distribution indicated by `mode'. -* - IF( MODE.EQ.0 ) THEN - CALL CLASET( 'Full', M, N, CMPLX( ZERO ), - $ CMPLX( ZERO ), A, LDA ) - DO 20 I = 1, MNMIN - S( I ) = ZERO - 20 CONTINUE - ELSE - CALL CLATMS( M, N, 'Uniform', ISEED, - $ 'Nonsymmetric', S, IMODE, - $ ONE / EPS, ONE, M, N, 'No packing', A, - $ LDA, WORK, INFO ) - CALL CGEQR2( M, N, A, LDA, WORK, WORK( MNMIN+1 ), - $ INFO ) - CALL CLASET( 'Lower', M-1, N, CMPLX( ZERO ), - $ CMPLX( ZERO ), A( 2 ), LDA ) - CALL SLAORD( 'Decreasing', MNMIN, S, 1 ) - END IF -* -* Save A and its singular values -* - CALL CLACPY( 'All', M, N, A, LDA, COPYA, LDA ) -* -* Call CTZRQF to reduce the upper trapezoidal matrix to -* upper triangular form. -* - SRNAMT = 'CTZRQF' - CALL CTZRQF( M, N, A, LDA, TAU, INFO ) -* -* Compute norm(svd(a) - svd(r)) -* - RESULT( 1 ) = CQRT12( M, M, A, LDA, S, WORK, - $ LWORK, RWORK ) -* -* Compute norm( A - R*Q ) -* - RESULT( 2 ) = CTZT01( M, N, COPYA, A, LDA, TAU, WORK, - $ LWORK ) -* -* Compute norm(Q'*Q - I). -* - RESULT( 3 ) = CTZT02( M, N, A, LDA, TAU, WORK, LWORK ) -* * Test CTZRZF * * Generate test matrix of size m by n using @@ -326,22 +279,22 @@ * * Compute norm(svd(a) - svd(r)) * - RESULT( 4 ) = CQRT12( M, M, A, LDA, S, WORK, + RESULT( 1 ) = CQRT12( M, M, A, LDA, S, WORK, $ LWORK, RWORK ) * * Compute norm( A - R*Q ) * - RESULT( 5 ) = CRZT01( M, N, COPYA, A, LDA, TAU, WORK, + RESULT( 2 ) = CRZT01( M, N, COPYA, A, LDA, TAU, WORK, $ LWORK ) * * Compute norm(Q'*Q - I). * - RESULT( 6 ) = CRZT02( M, N, A, LDA, TAU, WORK, LWORK ) + RESULT( 3 ) = CRZT02( M, N, A, LDA, TAU, WORK, LWORK ) * * Print information about the tests that did not pass * the threshold. * - DO 40 K = 1, 6 + DO 40 K = 1, NTESTS IF( RESULT( K ).GE.THRESH ) THEN IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) $ CALL ALAHD( NOUT, PATH ) @@ -350,7 +303,7 @@ NFAIL = NFAIL + 1 END IF 40 CONTINUE - NRUN = NRUN + 6 + NRUN = NRUN + 3 50 CONTINUE END IF 60 CONTINUE diff --git a/TESTING/LIN/cdrvls.f b/TESTING/LIN/cdrvls.f index 369d4468..b75bc38b 100644 --- a/TESTING/LIN/cdrvls.f +++ b/TESTING/LIN/cdrvls.f @@ -33,8 +33,8 @@ *> *> \verbatim *> -*> CDRVLS tests the least squares driver routines CGELS, CGELSX, CGELSS, -*> CGELSY and CGELSD. +*> CDRVLS tests the least squares driver routines CGELS, CGELSS, CGELSY +*> and CGELSD. *> \endverbatim * * Arguments: @@ -234,7 +234,7 @@ * * .. Parameters .. INTEGER NTESTS - PARAMETER ( NTESTS = 18 ) + PARAMETER ( NTESTS = 14 ) INTEGER SMLSIZ PARAMETER ( SMLSIZ = 25 ) REAL ONE, ZERO @@ -262,7 +262,7 @@ * .. * .. External Subroutines .. EXTERNAL ALAERH, ALAHD, ALASVM, CERRLS, CGELS, CGELSD, - $ CGELSS, CGELSX, CGELSY, CGEMM, CLACPY, CLARNV, + $ CGELSS, CGELSY, CGEMM, CLACPY, CLARNV, $ CQRT13, CQRT15, CQRT16, CSSCAL, SAXPY, $ XLAENV * .. @@ -444,79 +444,8 @@ * * workspace used: MAX(M+MIN(M,N),NRHS*MIN(M,N),2*N+M) * - DO 50 J = 1, N - IWORK( J ) = 0 - 50 CONTINUE LDWORK = MAX( 1, M ) * -* Test CGELSX -* -* CGELSX: Compute the minimum-norm solution X -* to min( norm( A * X - B ) ) -* using a complete orthogonal factorization. -* - CALL CLACPY( 'Full', M, N, COPYA, LDA, A, LDA ) - CALL CLACPY( 'Full', M, NRHS, COPYB, LDB, B, LDB ) -* - SRNAMT = 'CGELSX' - CALL CGELSX( M, N, NRHS, A, LDA, B, LDB, IWORK, - $ RCOND, CRANK, WORK, RWORK, INFO ) -* - IF( INFO.NE.0 ) - $ CALL ALAERH( PATH, 'CGELSX', INFO, 0, ' ', M, N, - $ NRHS, -1, NB, ITYPE, NFAIL, NERRS, - $ NOUT ) -* -* workspace used: MAX( MNMIN+3*N, 2*MNMIN+NRHS ) -* -* Test 3: Compute relative error in svd -* workspace: M*N + 4*MIN(M,N) + MAX(M,N) -* - RESULT( 3 ) = CQRT12( CRANK, CRANK, A, LDA, COPYS, - $ WORK, LWORK, RWORK ) -* -* Test 4: Compute error in solution -* workspace: M*NRHS + M -* - CALL CLACPY( 'Full', M, NRHS, COPYB, LDB, WORK, - $ LDWORK ) - CALL CQRT16( 'No transpose', M, N, NRHS, COPYA, - $ LDA, B, LDB, WORK, LDWORK, RWORK, - $ RESULT( 4 ) ) -* -* Test 5: Check norm of r'*A -* workspace: NRHS*(M+N) -* - RESULT( 5 ) = ZERO - IF( M.GT.CRANK ) - $ RESULT( 5 ) = CQRT17( 'No transpose', 1, M, N, - $ NRHS, COPYA, LDA, B, LDB, COPYB, - $ LDB, C, WORK, LWORK ) -* -* Test 6: Check if x is in the rowspace of A -* workspace: (M+NRHS)*(N+2) -* - RESULT( 6 ) = ZERO -* - IF( N.GT.CRANK ) - $ RESULT( 6 ) = CQRT14( 'No transpose', M, N, - $ NRHS, COPYA, LDA, B, LDB, WORK, - $ LWORK ) -* -* Print information about the tests that did not -* pass the threshold. -* - DO 60 K = 3, 6 - IF( RESULT( K ).GE.THRESH ) THEN - IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) - $ CALL ALAHD( NOUT, PATH ) - WRITE( NOUT, FMT = 9998 )M, N, NRHS, 0, - $ ITYPE, K, RESULT( K ) - NFAIL = NFAIL + 1 - END IF - 60 CONTINUE - NRUN = NRUN + 4 -* * Loop for testing different block sizes. * DO 90 INB = 1, NNB @@ -558,39 +487,39 @@ * * workspace used: 2*MNMIN+NB*NB+NB*MAX(N,NRHS) * -* Test 7: Compute relative error in svd +* Test 3: Compute relative error in svd * workspace: M*N + 4*MIN(M,N) + MAX(M,N) * - RESULT( 7 ) = CQRT12( CRANK, CRANK, A, LDA, + RESULT( 3 ) = CQRT12( CRANK, CRANK, A, LDA, $ COPYS, WORK, LWORK, RWORK ) * -* Test 8: Compute error in solution +* Test 4: Compute error in solution * workspace: M*NRHS + M * CALL CLACPY( 'Full', M, NRHS, COPYB, LDB, WORK, $ LDWORK ) CALL CQRT16( 'No transpose', M, N, NRHS, COPYA, $ LDA, B, LDB, WORK, LDWORK, RWORK, - $ RESULT( 8 ) ) + $ RESULT( 4 ) ) * -* Test 9: Check norm of r'*A +* Test 5: Check norm of r'*A * workspace: NRHS*(M+N) * - RESULT( 9 ) = ZERO + RESULT( 5 ) = ZERO IF( M.GT.CRANK ) - $ RESULT( 9 ) = CQRT17( 'No transpose', 1, M, + $ RESULT( 5 ) = CQRT17( 'No transpose', 1, M, $ N, NRHS, COPYA, LDA, B, LDB, $ COPYB, LDB, C, WORK, LWORK ) * -* Test 10: Check if x is in the rowspace of A +* Test 6: Check if x is in the rowspace of A * workspace: (M+NRHS)*(N+2) * - RESULT( 10 ) = ZERO + RESULT( 6 ) = ZERO * IF( N.GT.CRANK ) - $ RESULT( 10 ) = CQRT14( 'No transpose', M, N, - $ NRHS, COPYA, LDA, B, LDB, - $ WORK, LWORK ) + $ RESULT( 6 ) = CQRT14( 'No transpose', M, N, + $ NRHS, COPYA, LDA, B, LDB, + $ WORK, LWORK ) * * Test CGELSS * @@ -614,38 +543,38 @@ * workspace used: 3*min(m,n) + * max(2*min(m,n),nrhs,max(m,n)) * -* Test 11: Compute relative error in svd +* Test 7: Compute relative error in svd * IF( RANK.GT.0 ) THEN CALL SAXPY( MNMIN, -ONE, COPYS, 1, S, 1 ) - RESULT( 11 ) = SASUM( MNMIN, S, 1 ) / + RESULT( 7 ) = SASUM( MNMIN, S, 1 ) / $ SASUM( MNMIN, COPYS, 1 ) / $ ( EPS*REAL( MNMIN ) ) ELSE - RESULT( 11 ) = ZERO + RESULT( 7 ) = ZERO END IF * -* Test 12: Compute error in solution +* Test 8: Compute error in solution * CALL CLACPY( 'Full', M, NRHS, COPYB, LDB, WORK, $ LDWORK ) CALL CQRT16( 'No transpose', M, N, NRHS, COPYA, $ LDA, B, LDB, WORK, LDWORK, RWORK, - $ RESULT( 12 ) ) + $ RESULT( 8 ) ) * -* Test 13: Check norm of r'*A +* Test 9: Check norm of r'*A * - RESULT( 13 ) = ZERO + RESULT( 9 ) = ZERO IF( M.GT.CRANK ) - $ RESULT( 13 ) = CQRT17( 'No transpose', 1, M, + $ RESULT( 9 ) = CQRT17( 'No transpose', 1, M, $ N, NRHS, COPYA, LDA, B, LDB, $ COPYB, LDB, C, WORK, LWORK ) * -* Test 14: Check if x is in the rowspace of A +* Test 10: Check if x is in the rowspace of A * - RESULT( 14 ) = ZERO + RESULT( 10 ) = ZERO IF( N.GT.CRANK ) - $ RESULT( 14 ) = CQRT14( 'No transpose', M, N, + $ RESULT( 10 ) = CQRT14( 'No transpose', M, N, $ NRHS, COPYA, LDA, B, LDB, $ WORK, LWORK ) * @@ -670,45 +599,45 @@ $ N, NRHS, -1, NB, ITYPE, NFAIL, $ NERRS, NOUT ) * -* Test 15: Compute relative error in svd +* Test 11: Compute relative error in svd * IF( RANK.GT.0 ) THEN CALL SAXPY( MNMIN, -ONE, COPYS, 1, S, 1 ) - RESULT( 15 ) = SASUM( MNMIN, S, 1 ) / + RESULT( 11 ) = SASUM( MNMIN, S, 1 ) / $ SASUM( MNMIN, COPYS, 1 ) / $ ( EPS*REAL( MNMIN ) ) ELSE - RESULT( 15 ) = ZERO + RESULT( 11 ) = ZERO END IF * -* Test 16: Compute error in solution +* Test 12: Compute error in solution * CALL CLACPY( 'Full', M, NRHS, COPYB, LDB, WORK, $ LDWORK ) CALL CQRT16( 'No transpose', M, N, NRHS, COPYA, $ LDA, B, LDB, WORK, LDWORK, RWORK, - $ RESULT( 16 ) ) + $ RESULT( 12 ) ) * -* Test 17: Check norm of r'*A +* Test 13: Check norm of r'*A * - RESULT( 17 ) = ZERO + RESULT( 13 ) = ZERO IF( M.GT.CRANK ) - $ RESULT( 17 ) = CQRT17( 'No transpose', 1, M, + $ RESULT( 13 ) = CQRT17( 'No transpose', 1, M, $ N, NRHS, COPYA, LDA, B, LDB, $ COPYB, LDB, C, WORK, LWORK ) * -* Test 18: Check if x is in the rowspace of A +* Test 14: Check if x is in the rowspace of A * - RESULT( 18 ) = ZERO + RESULT( 14 ) = ZERO IF( N.GT.CRANK ) - $ RESULT( 18 ) = CQRT14( 'No transpose', M, N, + $ RESULT( 14 ) = CQRT14( 'No transpose', M, N, $ NRHS, COPYA, LDA, B, LDB, $ WORK, LWORK ) * * Print information about the tests that did not * pass the threshold. * - DO 80 K = 7, NTESTS + DO 80 K = 3, NTESTS IF( RESULT( K ).GE.THRESH ) THEN IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) $ CALL ALAHD( NOUT, PATH ) diff --git a/TESTING/LIN/cerrls.f b/TESTING/LIN/cerrls.f index b500a505..fff013b4 100644 --- a/TESTING/LIN/cerrls.f +++ b/TESTING/LIN/cerrls.f @@ -22,7 +22,7 @@ *> \verbatim *> *> CERRLS tests the error exits for the COMPLEX least squares -*> driver routines (CGELS, CGELSS, CGELSX, CGELSY, CGELSD). +*> driver routines (CGELS, CGELSS, CGELSY, CGELSD). *> \endverbatim * * Arguments: @@ -86,8 +86,7 @@ EXTERNAL LSAMEN * .. * .. External Subroutines .. - EXTERNAL ALAESM, CGELS, CGELSD, CGELSS, CGELSX, CGELSY, - $ CHKXER + EXTERNAL ALAESM, CGELS, CGELSD, CGELSS, CGELSY, CHKXER * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -162,30 +161,6 @@ $ INFO ) CALL CHKXER( 'CGELSS', INFOT, NOUT, LERR, OK ) * -* CGELSX -* - SRNAMT = 'CGELSX' - INFOT = 1 - CALL CGELSX( -1, 0, 0, A, 1, B, 1, IP, RCOND, IRNK, W, RW, - $ INFO ) - CALL CHKXER( 'CGELSX', INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL CGELSX( 0, -1, 0, A, 1, B, 1, IP, RCOND, IRNK, W, RW, - $ INFO ) - CALL CHKXER( 'CGELSX', INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL CGELSX( 0, 0, -1, A, 1, B, 1, IP, RCOND, IRNK, W, RW, - $ INFO ) - CALL CHKXER( 'CGELSX', INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL CGELSX( 2, 0, 0, A, 1, B, 2, IP, RCOND, IRNK, W, RW, - $ INFO ) - CALL CHKXER( 'CGELSX', INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL CGELSX( 2, 0, 0, A, 2, B, 1, IP, RCOND, IRNK, W, RW, - $ INFO ) - CALL CHKXER( 'CGELSX', INFOT, NOUT, LERR, OK ) -* * CGELSY * SRNAMT = 'CGELSY' diff --git a/TESTING/LIN/cerrtz.f b/TESTING/LIN/cerrtz.f index 4623832c..861cc9bc 100644 --- a/TESTING/LIN/cerrtz.f +++ b/TESTING/LIN/cerrtz.f @@ -21,7 +21,7 @@ *> *> \verbatim *> -*> CERRTZ tests the error exits for CTZRQF and CTZRZF. +*> CERRTZ tests the error exits for CTZRZF. *> \endverbatim * * Arguments: @@ -82,7 +82,7 @@ EXTERNAL LSAMEN * .. * .. External Subroutines .. - EXTERNAL ALAESM, CHKXER, CTZRQF, CTZRZF + EXTERNAL ALAESM, CHKXER, CTZRZF * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -113,19 +113,6 @@ WRITE( NOUT, FMT = * ) IF( LSAMEN( 2, C2, 'TZ' ) ) THEN * -* CTZRQF -* - SRNAMT = 'CTZRQF' - INFOT = 1 - CALL CTZRQF( -1, 0, A, 1, TAU, INFO ) - CALL CHKXER( 'CTZRQF', INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL CTZRQF( 1, 0, A, 1, TAU, INFO ) - CALL CHKXER( 'CTZRQF', INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL CTZRQF( 2, 2, A, 1, TAU, INFO ) - CALL CHKXER( 'CTZRQF', INFOT, NOUT, LERR, OK ) -* * CTZRZF * SRNAMT = 'CTZRZF' diff --git a/TESTING/LIN/ctzt01.f b/TESTING/LIN/ctzt01.f deleted file mode 100644 index aaaeeaaa..00000000 --- a/TESTING/LIN/ctzt01.f +++ /dev/null @@ -1,187 +0,0 @@ -*> \brief \b CTZT01 -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* REAL FUNCTION CTZT01( M, N, A, AF, LDA, TAU, WORK, -* LWORK ) -* -* .. Scalar Arguments .. -* INTEGER LDA, LWORK, M, N -* .. -* .. Array Arguments .. -* COMPLEX A( LDA, * ), AF( LDA, * ), TAU( * ), -* $ WORK( LWORK ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> CTZT01 returns -*> || A - R*Q || / ( M * eps * ||A|| ) -*> for an upper trapezoidal A that was factored with CTZRQF. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the matrices A and AF. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the matrices A and AF. -*> \endverbatim -*> -*> \param[in] A -*> \verbatim -*> A is COMPLEX array, dimension (LDA,N) -*> The original upper trapezoidal M by N matrix A. -*> \endverbatim -*> -*> \param[in] AF -*> \verbatim -*> AF is COMPLEX array, dimension (LDA,N) -*> The output of CTZRQF for input matrix A. -*> The lower triangle is not referenced. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the arrays A and AF. -*> \endverbatim -*> -*> \param[in] TAU -*> \verbatim -*> TAU is COMPLEX array, dimension (M) -*> Details of the Householder transformations as returned by -*> CTZRQF. -*> \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 >= m*n + m. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date November 2011 -* -*> \ingroup complex_lin -* -* ===================================================================== - REAL FUNCTION CTZT01( M, N, A, AF, LDA, TAU, WORK, - $ LWORK ) -* -* -- 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 .. - INTEGER LDA, LWORK, M, N -* .. -* .. Array Arguments .. - COMPLEX A( LDA, * ), AF( LDA, * ), TAU( * ), - $ WORK( LWORK ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - REAL ZERO, ONE - PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 ) -* .. -* .. Local Scalars .. - INTEGER I, J - REAL NORMA -* .. -* .. Local Arrays .. - REAL RWORK( 1 ) -* .. -* .. External Functions .. - REAL CLANGE, SLAMCH - EXTERNAL CLANGE, SLAMCH -* .. -* .. External Subroutines .. - EXTERNAL CAXPY, CLATZM, CLASET, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC CMPLX, MAX, REAL -* .. -* .. Executable Statements .. -* - CTZT01 = ZERO -* - IF( LWORK.LT.M*N+M ) THEN - CALL XERBLA( 'CTZT01', 8 ) - RETURN - END IF -* -* Quick return if possible -* - IF( M.LE.0 .OR. N.LE.0 ) - $ RETURN -* - NORMA = CLANGE( 'One-norm', M, N, A, LDA, RWORK ) -* -* Copy upper triangle R -* - CALL CLASET( 'Full', M, N, CMPLX( ZERO ), CMPLX( ZERO ), WORK, M ) - DO 20 J = 1, M - DO 10 I = 1, J - WORK( ( J-1 )*M+I ) = AF( I, J ) - 10 CONTINUE - 20 CONTINUE -* -* R = R * P(1) * ... *P(m) -* - DO 30 I = 1, M - CALL CLATZM( 'Right', I, N-M+1, AF( I, M+1 ), LDA, TAU( I ), - $ WORK( ( I-1 )*M+1 ), WORK( M*M+1 ), M, - $ WORK( M*N+1 ) ) - 30 CONTINUE -* -* R = R - A -* - DO 40 I = 1, N - CALL CAXPY( M, CMPLX( -ONE ), A( 1, I ), 1, - $ WORK( ( I-1 )*M+1 ), 1 ) - 40 CONTINUE -* - CTZT01 = CLANGE( 'One-norm', M, N, WORK, M, RWORK ) -* - CTZT01 = CTZT01 / ( SLAMCH( 'Epsilon' )*REAL( MAX( M, N ) ) ) - IF( NORMA.NE.ZERO ) - $ CTZT01 = CTZT01 / NORMA -* - RETURN -* -* End of CTZT01 -* - END diff --git a/TESTING/LIN/ctzt02.f b/TESTING/LIN/ctzt02.f deleted file mode 100644 index 45d05001..00000000 --- a/TESTING/LIN/ctzt02.f +++ /dev/null @@ -1,173 +0,0 @@ -*> \brief \b CTZT02 -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* REAL FUNCTION CTZT02( M, N, AF, LDA, TAU, WORK, -* LWORK ) -* -* .. Scalar Arguments .. -* INTEGER LDA, LWORK, M, N -* .. -* .. Array Arguments .. -* COMPLEX AF( LDA, * ), TAU( * ), WORK( LWORK ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> CTZT02 returns -*> || I - Q'*Q || / ( M * eps) -*> where the matrix Q is defined by the Householder transformations -*> generated by CTZRQF. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the matrix AF. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the matrix AF. -*> \endverbatim -*> -*> \param[in] AF -*> \verbatim -*> AF is COMPLEX array, dimension (LDA,N) -*> The output of CTZRQF. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array AF. -*> \endverbatim -*> -*> \param[in] TAU -*> \verbatim -*> TAU is COMPLEX array, dimension (M) -*> Details of the Householder transformations as returned by -*> CTZRQF. -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is COMPLEX array, dimension (LWORK) -*> \endverbatim -*> -*> \param[in] LWORK -*> \verbatim -*> LWORK is INTEGER -*> length of WORK array. Must be >= N*N+N -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date November 2011 -* -*> \ingroup complex_lin -* -* ===================================================================== - REAL FUNCTION CTZT02( M, N, AF, LDA, TAU, WORK, - $ LWORK ) -* -* -- 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 .. - INTEGER LDA, LWORK, M, N -* .. -* .. Array Arguments .. - COMPLEX AF( LDA, * ), TAU( * ), WORK( LWORK ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - REAL ZERO, ONE - PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 ) -* .. -* .. Local Scalars .. - INTEGER I -* .. -* .. Local Arrays .. - REAL RWORK( 1 ) -* .. -* .. External Functions .. - REAL CLANGE, SLAMCH - EXTERNAL CLANGE, SLAMCH -* .. -* .. External Subroutines .. - EXTERNAL CLATZM, CLASET, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC CMPLX, CONJG, MAX, REAL -* .. -* .. Executable Statements .. -* - CTZT02 = ZERO -* - IF( LWORK.LT.N*N+N ) THEN - CALL XERBLA( 'CTZT02', 7 ) - RETURN - END IF -* -* Quick return if possible -* - IF( M.LE.0 .OR. N.LE.0 ) - $ RETURN -* -* Q := I -* - CALL CLASET( 'Full', N, N, CMPLX( ZERO ), CMPLX( ONE ), WORK, N ) -* -* Q := P(1) * ... * P(m) * Q -* - DO 10 I = M, 1, -1 - CALL CLATZM( 'Left', N-M+1, N, AF( I, M+1 ), LDA, TAU( I ), - $ WORK( I ), WORK( M+1 ), N, WORK( N*N+1 ) ) - 10 CONTINUE -* -* Q := P(m)' * ... * P(1)' * Q -* - DO 20 I = 1, M - CALL CLATZM( 'Left', N-M+1, N, AF( I, M+1 ), LDA, - $ CONJG( TAU( I ) ), WORK( I ), WORK( M+1 ), N, - $ WORK( N*N+1 ) ) - 20 CONTINUE -* -* Q := Q - I -* - DO 30 I = 1, N - WORK( ( I-1 )*N+I ) = WORK( ( I-1 )*N+I ) - ONE - 30 CONTINUE -* - CTZT02 = CLANGE( 'One-norm', N, N, WORK, N, RWORK ) / - $ ( SLAMCH( 'Epsilon' )*REAL( MAX( M, N ) ) ) - RETURN -* -* End of CTZT02 -* - END diff --git a/TESTING/LIN/dchktz.f b/TESTING/LIN/dchktz.f index 0d77821b..327f3148 100644 --- a/TESTING/LIN/dchktz.f +++ b/TESTING/LIN/dchktz.f @@ -29,7 +29,7 @@ *> *> \verbatim *> -*> DCHKTZ tests DTZRQF and STZRZF. +*> DCHKTZ tests DTZRZF. *> \endverbatim * * Arguments: @@ -155,7 +155,7 @@ INTEGER NTYPES PARAMETER ( NTYPES = 3 ) INTEGER NTESTS - PARAMETER ( NTESTS = 6 ) + PARAMETER ( NTESTS = 3 ) DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) * .. @@ -170,12 +170,12 @@ DOUBLE PRECISION RESULT( NTESTS ) * .. * .. External Functions .. - DOUBLE PRECISION DLAMCH, DQRT12, DRZT01, DRZT02, DTZT01, DTZT02 - EXTERNAL DLAMCH, DQRT12, DRZT01, DRZT02, DTZT01, DTZT02 + DOUBLE PRECISION DLAMCH, DQRT12, DRZT01, DRZT02 + EXTERNAL DLAMCH, DQRT12, DRZT01, DRZT02 * .. * .. External Subroutines .. EXTERNAL ALAHD, ALASUM, DERRTZ, DGEQR2, DLACPY, DLAORD, - $ DLASET, DLATMS, DTZRQF, DTZRZF + $ DLASET, DLATMS, DTZRZF * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN @@ -246,52 +246,6 @@ * IF( MODE.EQ.0 ) THEN CALL DLASET( 'Full', M, N, ZERO, ZERO, A, LDA ) - DO 20 I = 1, MNMIN - S( I ) = ZERO - 20 CONTINUE - ELSE - CALL DLATMS( M, N, 'Uniform', ISEED, - $ 'Nonsymmetric', S, IMODE, - $ ONE / EPS, ONE, M, N, 'No packing', A, - $ LDA, WORK, INFO ) - CALL DGEQR2( M, N, A, LDA, WORK, WORK( MNMIN+1 ), - $ INFO ) - CALL DLASET( 'Lower', M-1, N, ZERO, ZERO, A( 2 ), - $ LDA ) - CALL DLAORD( 'Decreasing', MNMIN, S, 1 ) - END IF -* -* Save A and its singular values -* - CALL DLACPY( 'All', M, N, A, LDA, COPYA, LDA ) -* -* Call DTZRQF to reduce the upper trapezoidal matrix to -* upper triangular form. -* - SRNAMT = 'DTZRQF' - CALL DTZRQF( M, N, A, LDA, TAU, INFO ) -* -* Compute norm(svd(a) - svd(r)) -* - RESULT( 1 ) = DQRT12( M, M, A, LDA, S, WORK, - $ LWORK ) -* -* Compute norm( A - R*Q ) -* - RESULT( 2 ) = DTZT01( M, N, COPYA, A, LDA, TAU, WORK, - $ LWORK ) -* -* Compute norm(Q'*Q - I). -* - RESULT( 3 ) = DTZT02( M, N, A, LDA, TAU, WORK, LWORK ) -* -* Test DTZRZF -* -* Generate test matrix of size m by n using -* singular value distribution indicated by `mode'. -* - IF( MODE.EQ.0 ) THEN - CALL DLASET( 'Full', M, N, ZERO, ZERO, A, LDA ) DO 30 I = 1, MNMIN S( I ) = ZERO 30 CONTINUE @@ -319,22 +273,22 @@ * * Compute norm(svd(a) - svd(r)) * - RESULT( 4 ) = DQRT12( M, M, A, LDA, S, WORK, + RESULT( 1 ) = DQRT12( M, M, A, LDA, S, WORK, $ LWORK ) * * Compute norm( A - R*Q ) * - RESULT( 5 ) = DRZT01( M, N, COPYA, A, LDA, TAU, WORK, + RESULT( 2 ) = DRZT01( M, N, COPYA, A, LDA, TAU, WORK, $ LWORK ) * * Compute norm(Q'*Q - I). * - RESULT( 6 ) = DRZT02( M, N, A, LDA, TAU, WORK, LWORK ) + RESULT( 3 ) = DRZT02( M, N, A, LDA, TAU, WORK, LWORK ) * * Print information about the tests that did not pass * the threshold. * - DO 40 K = 1, 6 + DO 40 K = 1, NTESTS IF( RESULT( K ).GE.THRESH ) THEN IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) $ CALL ALAHD( NOUT, PATH ) @@ -343,7 +297,7 @@ NFAIL = NFAIL + 1 END IF 40 CONTINUE - NRUN = NRUN + 6 + NRUN = NRUN + 3 50 CONTINUE END IF 60 CONTINUE diff --git a/TESTING/LIN/ddrvls.f b/TESTING/LIN/ddrvls.f index 32e01f57..b11bb02a 100644 --- a/TESTING/LIN/ddrvls.f +++ b/TESTING/LIN/ddrvls.f @@ -31,8 +31,8 @@ *> *> \verbatim *> -*> DDRVLS tests the least squares driver routines DGELS, DGELSS, DGELSX, -*> DGELSY and DGELSD. +*> DDRVLS tests the least squares driver routines DGELS, DGELSS, DGELSY, +*> and DGELSD. *> \endverbatim * * Arguments: @@ -225,7 +225,7 @@ * * .. Parameters .. INTEGER NTESTS - PARAMETER ( NTESTS = 18 ) + PARAMETER ( NTESTS = 14 ) INTEGER SMLSIZ PARAMETER ( SMLSIZ = 25 ) DOUBLE PRECISION ONE, TWO, ZERO @@ -250,7 +250,7 @@ * .. * .. External Subroutines .. EXTERNAL ALAERH, ALAHD, ALASVM, DAXPY, DERRLS, DGELS, - $ DGELSD, DGELSS, DGELSX, DGELSY, DGEMM, DLACPY, + $ DGELSD, DGELSS, DGELSY, DGEMM, DLACPY, $ DLARNV, DLASRT, DQRT13, DQRT15, DQRT16, DSCAL, $ XLAENV * .. @@ -437,80 +437,8 @@ * * workspace used: MAX(M+MIN(M,N),NRHS*MIN(M,N),2*N+M) * -* Initialize vector IWORK. -* - DO 50 J = 1, N - IWORK( J ) = 0 - 50 CONTINUE LDWORK = MAX( 1, M ) * -* Test DGELSX -* -* DGELSX: Compute the minimum-norm solution X -* to min( norm( A * X - B ) ) using a complete -* orthogonal factorization. -* - CALL DLACPY( 'Full', M, N, COPYA, LDA, A, LDA ) - CALL DLACPY( 'Full', M, NRHS, COPYB, LDB, B, LDB ) -* - SRNAMT = 'DGELSX' - CALL DGELSX( M, N, NRHS, A, LDA, B, LDB, IWORK, - $ RCOND, CRANK, WORK, INFO ) - IF( INFO.NE.0 ) - $ CALL ALAERH( PATH, 'DGELSX', INFO, 0, ' ', M, N, - $ NRHS, -1, NB, ITYPE, NFAIL, NERRS, - $ NOUT ) -* -* workspace used: MAX( MNMIN+3*N, 2*MNMIN+NRHS ) -* -* Test 3: Compute relative error in svd -* workspace: M*N + 4*MIN(M,N) + MAX(M,N) -* - RESULT( 3 ) = DQRT12( CRANK, CRANK, A, LDA, COPYS, - $ WORK, LWORK ) -* -* Test 4: Compute error in solution -* workspace: M*NRHS + M -* - CALL DLACPY( 'Full', M, NRHS, COPYB, LDB, WORK, - $ LDWORK ) - CALL DQRT16( 'No transpose', M, N, NRHS, COPYA, - $ LDA, B, LDB, WORK, LDWORK, - $ WORK( M*NRHS+1 ), RESULT( 4 ) ) -* -* Test 5: Check norm of r'*A -* workspace: NRHS*(M+N) -* - RESULT( 5 ) = ZERO - IF( M.GT.CRANK ) - $ RESULT( 5 ) = DQRT17( 'No transpose', 1, M, N, - $ NRHS, COPYA, LDA, B, LDB, COPYB, - $ LDB, C, WORK, LWORK ) -* -* Test 6: Check if x is in the rowspace of A -* workspace: (M+NRHS)*(N+2) -* - RESULT( 6 ) = ZERO -* - IF( N.GT.CRANK ) - $ RESULT( 6 ) = DQRT14( 'No transpose', M, N, - $ NRHS, COPYA, LDA, B, LDB, WORK, - $ LWORK ) -* -* Print information about the tests that did not -* pass the threshold. -* - DO 60 K = 3, 6 - IF( RESULT( K ).GE.THRESH ) THEN - IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) - $ CALL ALAHD( NOUT, PATH ) - WRITE( NOUT, FMT = 9998 )M, N, NRHS, NB, - $ ITYPE, K, RESULT( K ) - NFAIL = NFAIL + 1 - END IF - 60 CONTINUE - NRUN = NRUN + 4 -* * Loop for testing different block sizes. * DO 100 INB = 1, NNB @@ -548,39 +476,39 @@ $ N, NRHS, -1, NB, ITYPE, NFAIL, $ NERRS, NOUT ) * -* Test 7: Compute relative error in svd +* Test 3: Compute relative error in svd * workspace: M*N + 4*MIN(M,N) + MAX(M,N) * - RESULT( 7 ) = DQRT12( CRANK, CRANK, A, LDA, + RESULT( 3 ) = DQRT12( CRANK, CRANK, A, LDA, $ COPYS, WORK, LWORK ) * -* Test 8: Compute error in solution +* Test 4: Compute error in solution * workspace: M*NRHS + M * CALL DLACPY( 'Full', M, NRHS, COPYB, LDB, WORK, $ LDWORK ) CALL DQRT16( 'No transpose', M, N, NRHS, COPYA, $ LDA, B, LDB, WORK, LDWORK, - $ WORK( M*NRHS+1 ), RESULT( 8 ) ) + $ WORK( M*NRHS+1 ), RESULT( 4 ) ) * -* Test 9: Check norm of r'*A +* Test 5: Check norm of r'*A * workspace: NRHS*(M+N) * - RESULT( 9 ) = ZERO + RESULT( 5 ) = ZERO IF( M.GT.CRANK ) - $ RESULT( 9 ) = DQRT17( 'No transpose', 1, M, + $ RESULT( 5 ) = DQRT17( 'No transpose', 1, M, $ N, NRHS, COPYA, LDA, B, LDB, $ COPYB, LDB, C, WORK, LWORK ) * -* Test 10: Check if x is in the rowspace of A +* Test 6: Check if x is in the rowspace of A * workspace: (M+NRHS)*(N+2) * - RESULT( 10 ) = ZERO + RESULT( 6 ) = ZERO * IF( N.GT.CRANK ) - $ RESULT( 10 ) = DQRT14( 'No transpose', M, N, - $ NRHS, COPYA, LDA, B, LDB, - $ WORK, LWORK ) + $ RESULT( 6 ) = DQRT14( 'No transpose', M, N, + $ NRHS, COPYA, LDA, B, LDB, + $ WORK, LWORK ) * * Test DGELSS * @@ -602,38 +530,38 @@ * workspace used: 3*min(m,n) + * max(2*min(m,n),nrhs,max(m,n)) * -* Test 11: Compute relative error in svd +* Test 7: Compute relative error in svd * IF( RANK.GT.0 ) THEN CALL DAXPY( MNMIN, -ONE, COPYS, 1, S, 1 ) - RESULT( 11 ) = DASUM( MNMIN, S, 1 ) / - $ DASUM( MNMIN, COPYS, 1 ) / - $ ( EPS*DBLE( MNMIN ) ) + RESULT( 7 ) = DASUM( MNMIN, S, 1 ) / + $ DASUM( MNMIN, COPYS, 1 ) / + $ ( EPS*DBLE( MNMIN ) ) ELSE - RESULT( 11 ) = ZERO + RESULT( 7 ) = ZERO END IF * -* Test 12: Compute error in solution +* Test 8: Compute error in solution * CALL DLACPY( 'Full', M, NRHS, COPYB, LDB, WORK, $ LDWORK ) CALL DQRT16( 'No transpose', M, N, NRHS, COPYA, $ LDA, B, LDB, WORK, LDWORK, - $ WORK( M*NRHS+1 ), RESULT( 12 ) ) + $ WORK( M*NRHS+1 ), RESULT( 8 ) ) * -* Test 13: Check norm of r'*A +* Test 9: Check norm of r'*A * - RESULT( 13 ) = ZERO + RESULT( 9 ) = ZERO IF( M.GT.CRANK ) - $ RESULT( 13 ) = DQRT17( 'No transpose', 1, M, - $ N, NRHS, COPYA, LDA, B, LDB, - $ COPYB, LDB, C, WORK, LWORK ) + $ RESULT( 9 ) = DQRT17( 'No transpose', 1, M, + $ N, NRHS, COPYA, LDA, B, LDB, + $ COPYB, LDB, C, WORK, LWORK ) * -* Test 14: Check if x is in the rowspace of A +* Test 10: Check if x is in the rowspace of A * - RESULT( 14 ) = ZERO + RESULT( 10 ) = ZERO IF( N.GT.CRANK ) - $ RESULT( 14 ) = DQRT14( 'No transpose', M, N, + $ RESULT( 10 ) = DQRT14( 'No transpose', M, N, $ NRHS, COPYA, LDA, B, LDB, $ WORK, LWORK ) * @@ -662,45 +590,45 @@ $ N, NRHS, -1, NB, ITYPE, NFAIL, $ NERRS, NOUT ) * -* Test 15: Compute relative error in svd +* Test 11: Compute relative error in svd * IF( RANK.GT.0 ) THEN CALL DAXPY( MNMIN, -ONE, COPYS, 1, S, 1 ) - RESULT( 15 ) = DASUM( MNMIN, S, 1 ) / + RESULT( 11 ) = DASUM( MNMIN, S, 1 ) / $ DASUM( MNMIN, COPYS, 1 ) / $ ( EPS*DBLE( MNMIN ) ) ELSE - RESULT( 15 ) = ZERO + RESULT( 11 ) = ZERO END IF * -* Test 16: Compute error in solution +* Test 12: Compute error in solution * CALL DLACPY( 'Full', M, NRHS, COPYB, LDB, WORK, $ LDWORK ) CALL DQRT16( 'No transpose', M, N, NRHS, COPYA, $ LDA, B, LDB, WORK, LDWORK, - $ WORK( M*NRHS+1 ), RESULT( 16 ) ) + $ WORK( M*NRHS+1 ), RESULT( 12 ) ) * -* Test 17: Check norm of r'*A +* Test 13: Check norm of r'*A * - RESULT( 17 ) = ZERO + RESULT( 13 ) = ZERO IF( M.GT.CRANK ) - $ RESULT( 17 ) = DQRT17( 'No transpose', 1, M, + $ RESULT( 13 ) = DQRT17( 'No transpose', 1, M, $ N, NRHS, COPYA, LDA, B, LDB, $ COPYB, LDB, C, WORK, LWORK ) * -* Test 18: Check if x is in the rowspace of A +* Test 14: Check if x is in the rowspace of A * - RESULT( 18 ) = ZERO + RESULT( 14 ) = ZERO IF( N.GT.CRANK ) - $ RESULT( 18 ) = DQRT14( 'No transpose', M, N, + $ RESULT( 14 ) = DQRT14( 'No transpose', M, N, $ NRHS, COPYA, LDA, B, LDB, $ WORK, LWORK ) * * Print information about the tests that did not * pass the threshold. * - DO 90 K = 7, NTESTS + DO 90 K = 3, NTESTS IF( RESULT( K ).GE.THRESH ) THEN IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) $ CALL ALAHD( NOUT, PATH ) diff --git a/TESTING/LIN/derrls.f b/TESTING/LIN/derrls.f index 3304ea5e..e59d7de6 100644 --- a/TESTING/LIN/derrls.f +++ b/TESTING/LIN/derrls.f @@ -22,7 +22,7 @@ *> \verbatim *> *> DERRLS tests the error exits for the DOUBLE PRECISION least squares -*> driver routines (DGELS, SGELSS, SGELSX, SGELSY, SGELSD). +*> driver routines (DGELS, SGELSS, SGELSY, SGELSD). *> \endverbatim * * Arguments: @@ -86,8 +86,7 @@ EXTERNAL LSAMEN * .. * .. External Subroutines .. - EXTERNAL ALAESM, CHKXER, DGELS, DGELSD, DGELSS, DGELSX, - $ DGELSY + EXTERNAL ALAESM, CHKXER, DGELS, DGELSD, DGELSS, DGELSY * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -157,25 +156,6 @@ CALL DGELSS( 2, 0, 0, A, 2, B, 1, S, RCOND, IRNK, W, 2, INFO ) CALL CHKXER( 'DGELSS', INFOT, NOUT, LERR, OK ) * -* DGELSX -* - SRNAMT = 'DGELSX' - INFOT = 1 - CALL DGELSX( -1, 0, 0, A, 1, B, 1, IP, RCOND, IRNK, W, INFO ) - CALL CHKXER( 'DGELSX', INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL DGELSX( 0, -1, 0, A, 1, B, 1, IP, RCOND, IRNK, W, INFO ) - CALL CHKXER( 'DGELSX', INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL DGELSX( 0, 0, -1, A, 1, B, 1, IP, RCOND, IRNK, W, INFO ) - CALL CHKXER( 'DGELSX', INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL DGELSX( 2, 0, 0, A, 1, B, 2, IP, RCOND, IRNK, W, INFO ) - CALL CHKXER( 'DGELSX', INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL DGELSX( 2, 0, 0, A, 2, B, 1, IP, RCOND, IRNK, W, INFO ) - CALL CHKXER( 'DGELSX', INFOT, NOUT, LERR, OK ) -* * DGELSY * SRNAMT = 'DGELSY' diff --git a/TESTING/LIN/derrtz.f b/TESTING/LIN/derrtz.f index 9b89ae3f..46d8c788 100644 --- a/TESTING/LIN/derrtz.f +++ b/TESTING/LIN/derrtz.f @@ -21,7 +21,7 @@ *> *> \verbatim *> -*> DERRTZ tests the error exits for DTZRQF and STZRZF. +*> DERRTZ tests the error exits for STZRZF. *> \endverbatim * * Arguments: @@ -82,7 +82,7 @@ EXTERNAL LSAMEN * .. * .. External Subroutines .. - EXTERNAL ALAESM, CHKXER, DTZRQF, DTZRZF + EXTERNAL ALAESM, CHKXER, DTZRZF * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -110,19 +110,6 @@ * * Test error exits for the trapezoidal routines. * -* DTZRQF -* - SRNAMT = 'DTZRQF' - INFOT = 1 - CALL DTZRQF( -1, 0, A, 1, TAU, INFO ) - CALL CHKXER( 'DTZRQF', INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL DTZRQF( 1, 0, A, 1, TAU, INFO ) - CALL CHKXER( 'DTZRQF', INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL DTZRQF( 2, 2, A, 1, TAU, INFO ) - CALL CHKXER( 'DTZRQF', INFOT, NOUT, LERR, OK ) -* * DTZRZF * SRNAMT = 'DTZRZF' diff --git a/TESTING/LIN/dtzt01.f b/TESTING/LIN/dtzt01.f deleted file mode 100644 index 3ecf9850..00000000 --- a/TESTING/LIN/dtzt01.f +++ /dev/null @@ -1,186 +0,0 @@ -*> \brief \b DTZT01 -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* DOUBLE PRECISION FUNCTION DTZT01( M, N, A, AF, LDA, TAU, WORK, -* LWORK ) -* -* .. Scalar Arguments .. -* INTEGER LDA, LWORK, M, N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A( LDA, * ), AF( LDA, * ), TAU( * ), -* $ WORK( LWORK ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DTZT01 returns -*> || A - R*Q || / ( M * eps * ||A|| ) -*> for an upper trapezoidal A that was factored with DTZRQF. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the matrices A and AF. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the matrices A and AF. -*> \endverbatim -*> -*> \param[in] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA,N) -*> The original upper trapezoidal M by N matrix A. -*> \endverbatim -*> -*> \param[in] AF -*> \verbatim -*> AF is DOUBLE PRECISION array, dimension (LDA,N) -*> The output of DTZRQF for input matrix A. -*> The lower triangle is not referenced. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the arrays A and AF. -*> \endverbatim -*> -*> \param[in] TAU -*> \verbatim -*> TAU is DOUBLE PRECISION array, dimension (M) -*> Details of the Householder transformations as returned by -*> DTZRQF. -*> \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 >= m*n + m. -*> \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 -* -* ===================================================================== - DOUBLE PRECISION FUNCTION DTZT01( M, N, A, AF, LDA, TAU, WORK, - $ LWORK ) -* -* -- 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 .. - INTEGER LDA, LWORK, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), AF( LDA, * ), TAU( * ), - $ WORK( LWORK ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -* .. -* .. Local Scalars .. - INTEGER I, J - DOUBLE PRECISION NORMA -* .. -* .. Local Arrays .. - DOUBLE PRECISION RWORK( 1 ) -* .. -* .. External Functions .. - DOUBLE PRECISION DLAMCH, DLANGE - EXTERNAL DLAMCH, DLANGE -* .. -* .. External Subroutines .. - EXTERNAL DAXPY, DLASET, DLATZM, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC DBLE, MAX -* .. -* .. Executable Statements .. -* - DTZT01 = ZERO -* - IF( LWORK.LT.M*N+M ) THEN - CALL XERBLA( 'DTZT01', 8 ) - RETURN - END IF -* -* Quick return if possible -* - IF( M.LE.0 .OR. N.LE.0 ) - $ RETURN -* - NORMA = DLANGE( 'One-norm', M, N, A, LDA, RWORK ) -* -* Copy upper triangle R -* - CALL DLASET( 'Full', M, N, ZERO, ZERO, WORK, M ) - DO 20 J = 1, M - DO 10 I = 1, J - WORK( ( J-1 )*M+I ) = AF( I, J ) - 10 CONTINUE - 20 CONTINUE -* -* R = R * P(1) * ... *P(m) -* - DO 30 I = 1, M - CALL DLATZM( 'Right', I, N-M+1, AF( I, M+1 ), LDA, TAU( I ), - $ WORK( ( I-1 )*M+1 ), WORK( M*M+1 ), M, - $ WORK( M*N+1 ) ) - 30 CONTINUE -* -* R = R - A -* - DO 40 I = 1, N - CALL DAXPY( M, -ONE, A( 1, I ), 1, WORK( ( I-1 )*M+1 ), 1 ) - 40 CONTINUE -* - DTZT01 = DLANGE( 'One-norm', M, N, WORK, M, RWORK ) -* - DTZT01 = DTZT01 / ( DLAMCH( 'Epsilon' )*DBLE( MAX( M, N ) ) ) - IF( NORMA.NE.ZERO ) - $ DTZT01 = DTZT01 / NORMA -* - RETURN -* -* End of DTZT01 -* - END diff --git a/TESTING/LIN/dtzt02.f b/TESTING/LIN/dtzt02.f deleted file mode 100644 index b8a962aa..00000000 --- a/TESTING/LIN/dtzt02.f +++ /dev/null @@ -1,172 +0,0 @@ -*> \brief \b DTZT02 -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* DOUBLE PRECISION FUNCTION DTZT02( M, N, AF, LDA, TAU, WORK, -* LWORK ) -* -* .. Scalar Arguments .. -* INTEGER LDA, LWORK, M, N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION AF( LDA, * ), TAU( * ), WORK( LWORK ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DTZT02 returns -*> || I - Q'*Q || / ( M * eps) -*> where the matrix Q is defined by the Householder transformations -*> generated by DTZRQF. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the matrix AF. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the matrix AF. -*> \endverbatim -*> -*> \param[in] AF -*> \verbatim -*> AF is DOUBLE PRECISION array, dimension (LDA,N) -*> The output of DTZRQF. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array AF. -*> \endverbatim -*> -*> \param[in] TAU -*> \verbatim -*> TAU is DOUBLE PRECISION array, dimension (M) -*> Details of the Householder transformations as returned by -*> DTZRQF. -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, dimension (LWORK) -*> \endverbatim -*> -*> \param[in] LWORK -*> \verbatim -*> LWORK is INTEGER -*> length of WORK array. Must be >= N*N+N -*> \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 -* -* ===================================================================== - DOUBLE PRECISION FUNCTION DTZT02( M, N, AF, LDA, TAU, WORK, - $ LWORK ) -* -* -- 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 .. - INTEGER LDA, LWORK, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION AF( LDA, * ), TAU( * ), WORK( LWORK ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -* .. -* .. Local Scalars .. - INTEGER I -* .. -* .. Local Arrays .. - DOUBLE PRECISION RWORK( 1 ) -* .. -* .. External Functions .. - DOUBLE PRECISION DLAMCH, DLANGE - EXTERNAL DLAMCH, DLANGE -* .. -* .. External Subroutines .. - EXTERNAL DLASET, DLATZM, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC DBLE, MAX -* .. -* .. Executable Statements .. -* - DTZT02 = ZERO -* - IF( LWORK.LT.N*N+N ) THEN - CALL XERBLA( 'DTZT02', 7 ) - RETURN - END IF -* -* Quick return if possible -* - IF( M.LE.0 .OR. N.LE.0 ) - $ RETURN -* -* Q := I -* - CALL DLASET( 'Full', N, N, ZERO, ONE, WORK, N ) -* -* Q := P(1) * ... * P(m) * Q -* - DO 10 I = M, 1, -1 - CALL DLATZM( 'Left', N-M+1, N, AF( I, M+1 ), LDA, TAU( I ), - $ WORK( I ), WORK( M+1 ), N, WORK( N*N+1 ) ) - 10 CONTINUE -* -* Q := P(m) * ... * P(1) * Q -* - DO 20 I = 1, M - CALL DLATZM( 'Left', N-M+1, N, AF( I, M+1 ), LDA, TAU( I ), - $ WORK( I ), WORK( M+1 ), N, WORK( N*N+1 ) ) - 20 CONTINUE -* -* Q := Q - I -* - DO 30 I = 1, N - WORK( ( I-1 )*N+I ) = WORK( ( I-1 )*N+I ) - ONE - 30 CONTINUE -* - DTZT02 = DLANGE( 'One-norm', N, N, WORK, N, RWORK ) / - $ ( DLAMCH( 'Epsilon' )*DBLE( MAX( M, N ) ) ) - RETURN -* -* End of DTZT02 -* - END diff --git a/TESTING/LIN/schktz.f b/TESTING/LIN/schktz.f index 00d83bde..4d226365 100644 --- a/TESTING/LIN/schktz.f +++ b/TESTING/LIN/schktz.f @@ -29,7 +29,7 @@ *> *> \verbatim *> -*> SCHKTZ tests STZRQF and STZRZF. +*> SCHKTZ tests STZRZF. *> \endverbatim * * Arguments: @@ -155,7 +155,7 @@ INTEGER NTYPES PARAMETER ( NTYPES = 3 ) INTEGER NTESTS - PARAMETER ( NTESTS = 6 ) + PARAMETER ( NTESTS = 3 ) REAL ONE, ZERO PARAMETER ( ONE = 1.0E0, ZERO = 0.0E0 ) * .. @@ -170,12 +170,12 @@ REAL RESULT( NTESTS ) * .. * .. External Functions .. - REAL SLAMCH, SQRT12, SRZT01, SRZT02, STZT01, STZT02 - EXTERNAL SLAMCH, SQRT12, SRZT01, SRZT02, STZT01, STZT02 + REAL SLAMCH, SQRT12, SRZT01, SRZT02 + EXTERNAL SLAMCH, SQRT12, SRZT01, SRZT02 * .. * .. External Subroutines .. EXTERNAL ALAHD, ALASUM, SERRTZ, SGEQR2, SLACPY, SLAORD, - $ SLASET, SLATMS, STZRQF, STZRZF + $ SLASET, SLATMS, STZRZF * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN @@ -246,52 +246,6 @@ * IF( MODE.EQ.0 ) THEN CALL SLASET( 'Full', M, N, ZERO, ZERO, A, LDA ) - DO 20 I = 1, MNMIN - S( I ) = ZERO - 20 CONTINUE - ELSE - CALL SLATMS( M, N, 'Uniform', ISEED, - $ 'Nonsymmetric', S, IMODE, - $ ONE / EPS, ONE, M, N, 'No packing', A, - $ LDA, WORK, INFO ) - CALL SGEQR2( M, N, A, LDA, WORK, WORK( MNMIN+1 ), - $ INFO ) - CALL SLASET( 'Lower', M-1, N, ZERO, ZERO, A( 2 ), - $ LDA ) - CALL SLAORD( 'Decreasing', MNMIN, S, 1 ) - END IF -* -* Save A and its singular values -* - CALL SLACPY( 'All', M, N, A, LDA, COPYA, LDA ) -* -* Call STZRQF to reduce the upper trapezoidal matrix to -* upper triangular form. -* - SRNAMT = 'STZRQF' - CALL STZRQF( M, N, A, LDA, TAU, INFO ) -* -* Compute norm(svd(a) - svd(r)) -* - RESULT( 1 ) = SQRT12( M, M, A, LDA, S, WORK, - $ LWORK ) -* -* Compute norm( A - R*Q ) -* - RESULT( 2 ) = STZT01( M, N, COPYA, A, LDA, TAU, WORK, - $ LWORK ) -* -* Compute norm(Q'*Q - I). -* - RESULT( 3 ) = STZT02( M, N, A, LDA, TAU, WORK, LWORK ) -* -* Test STZRZF -* -* Generate test matrix of size m by n using -* singular value distribution indicated by `mode'. -* - IF( MODE.EQ.0 ) THEN - CALL SLASET( 'Full', M, N, ZERO, ZERO, A, LDA ) DO 30 I = 1, MNMIN S( I ) = ZERO 30 CONTINUE @@ -319,22 +273,22 @@ * * Compute norm(svd(a) - svd(r)) * - RESULT( 4 ) = SQRT12( M, M, A, LDA, S, WORK, + RESULT( 1 ) = SQRT12( M, M, A, LDA, S, WORK, $ LWORK ) * * Compute norm( A - R*Q ) * - RESULT( 5 ) = SRZT01( M, N, COPYA, A, LDA, TAU, WORK, + RESULT( 2 ) = SRZT01( M, N, COPYA, A, LDA, TAU, WORK, $ LWORK ) * * Compute norm(Q'*Q - I). * - RESULT( 6 ) = SRZT02( M, N, A, LDA, TAU, WORK, LWORK ) + RESULT( 3 ) = SRZT02( M, N, A, LDA, TAU, WORK, LWORK ) * * Print information about the tests that did not pass * the threshold. * - DO 40 K = 1, 6 + DO 40 K = 1, NTESTS IF( RESULT( K ).GE.THRESH ) THEN IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) $ CALL ALAHD( NOUT, PATH ) @@ -343,7 +297,7 @@ NFAIL = NFAIL + 1 END IF 40 CONTINUE - NRUN = NRUN + 6 + NRUN = NRUN + 3 50 CONTINUE END IF 60 CONTINUE diff --git a/TESTING/LIN/sdrvls.f b/TESTING/LIN/sdrvls.f index 879b3384..adad4e6e 100644 --- a/TESTING/LIN/sdrvls.f +++ b/TESTING/LIN/sdrvls.f @@ -31,8 +31,8 @@ *> *> \verbatim *> -*> SDRVLS tests the least squares driver routines SGELS, SGELSS, SGELSX, -*> SGELSY and SGELSD. +*> SDRVLS tests the least squares driver routines SGELS, SGELSS, SGELSY +*> and SGELSD. *> \endverbatim * * Arguments: @@ -225,7 +225,7 @@ * * .. Parameters .. INTEGER NTESTS - PARAMETER ( NTESTS = 18 ) + PARAMETER ( NTESTS = 14 ) INTEGER SMLSIZ PARAMETER ( SMLSIZ = 25 ) REAL ONE, TWO, ZERO @@ -250,7 +250,7 @@ * .. * .. External Subroutines .. EXTERNAL ALAERH, ALAHD, ALASVM, SAXPY, SERRLS, SGELS, - $ SGELSD, SGELSS, SGELSX, SGELSY, SGEMM, SLACPY, + $ SGELSD, SGELSS, SGELSY, SGEMM, SLACPY, $ SLARNV, SQRT13, SQRT15, SQRT16, SSCAL, $ XLAENV * .. @@ -435,80 +435,8 @@ * * workspace used: MAX(M+MIN(M,N),NRHS*MIN(M,N),2*N+M) * -* Initialize vector IWORK. -* - DO 50 J = 1, N - IWORK( J ) = 0 - 50 CONTINUE LDWORK = MAX( 1, M ) * -* Test SGELSX -* -* SGELSX: Compute the minimum-norm solution X -* to min( norm( A * X - B ) ) using a complete -* orthogonal factorization. -* - CALL SLACPY( 'Full', M, N, COPYA, LDA, A, LDA ) - CALL SLACPY( 'Full', M, NRHS, COPYB, LDB, B, LDB ) -* - SRNAMT = 'SGELSX' - CALL SGELSX( M, N, NRHS, A, LDA, B, LDB, IWORK, - $ RCOND, CRANK, WORK, INFO ) - IF( INFO.NE.0 ) - $ CALL ALAERH( PATH, 'SGELSX', INFO, 0, ' ', M, N, - $ NRHS, -1, NB, ITYPE, NFAIL, NERRS, - $ NOUT ) -* -* workspace used: MAX( MNMIN+3*N, 2*MNMIN+NRHS ) -* -* Test 3: Compute relative error in svd -* workspace: M*N + 4*MIN(M,N) + MAX(M,N) -* - RESULT( 3 ) = SQRT12( CRANK, CRANK, A, LDA, COPYS, - $ WORK, LWORK ) -* -* Test 4: Compute error in solution -* workspace: M*NRHS + M -* - CALL SLACPY( 'Full', M, NRHS, COPYB, LDB, WORK, - $ LDWORK ) - CALL SQRT16( 'No transpose', M, N, NRHS, COPYA, - $ LDA, B, LDB, WORK, LDWORK, - $ WORK( M*NRHS+1 ), RESULT( 4 ) ) -* -* Test 5: Check norm of r'*A -* workspace: NRHS*(M+N) -* - RESULT( 5 ) = ZERO - IF( M.GT.CRANK ) - $ RESULT( 5 ) = SQRT17( 'No transpose', 1, M, N, - $ NRHS, COPYA, LDA, B, LDB, COPYB, - $ LDB, C, WORK, LWORK ) -* -* Test 6: Check if x is in the rowspace of A -* workspace: (M+NRHS)*(N+2) -* - RESULT( 6 ) = ZERO -* - IF( N.GT.CRANK ) - $ RESULT( 6 ) = SQRT14( 'No transpose', M, N, - $ NRHS, COPYA, LDA, B, LDB, WORK, - $ LWORK ) -* -* Print information about the tests that did not -* pass the threshold. -* - DO 60 K = 3, 6 - IF( RESULT( K ).GE.THRESH ) THEN - IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) - $ CALL ALAHD( NOUT, PATH ) - WRITE( NOUT, FMT = 9998 )M, N, NRHS, NB, - $ ITYPE, K, RESULT( K ) - NFAIL = NFAIL + 1 - END IF - 60 CONTINUE - NRUN = NRUN + 4 -* * Loop for testing different block sizes. * DO 100 INB = 1, NNB @@ -546,39 +474,39 @@ $ N, NRHS, -1, NB, ITYPE, NFAIL, $ NERRS, NOUT ) * -* Test 7: Compute relative error in svd +* Test 3: Compute relative error in svd * workspace: M*N + 4*MIN(M,N) + MAX(M,N) * - RESULT( 7 ) = SQRT12( CRANK, CRANK, A, LDA, + RESULT( 3 ) = SQRT12( CRANK, CRANK, A, LDA, $ COPYS, WORK, LWORK ) * -* Test 8: Compute error in solution +* Test 4: Compute error in solution * workspace: M*NRHS + M * CALL SLACPY( 'Full', M, NRHS, COPYB, LDB, WORK, $ LDWORK ) CALL SQRT16( 'No transpose', M, N, NRHS, COPYA, $ LDA, B, LDB, WORK, LDWORK, - $ WORK( M*NRHS+1 ), RESULT( 8 ) ) + $ WORK( M*NRHS+1 ), RESULT( 4 ) ) * -* Test 9: Check norm of r'*A +* Test 5: Check norm of r'*A * workspace: NRHS*(M+N) * - RESULT( 9 ) = ZERO + RESULT( 5 ) = ZERO IF( M.GT.CRANK ) - $ RESULT( 9 ) = SQRT17( 'No transpose', 1, M, + $ RESULT( 5 ) = SQRT17( 'No transpose', 1, M, $ N, NRHS, COPYA, LDA, B, LDB, $ COPYB, LDB, C, WORK, LWORK ) * -* Test 10: Check if x is in the rowspace of A +* Test 6: Check if x is in the rowspace of A * workspace: (M+NRHS)*(N+2) * - RESULT( 10 ) = ZERO + RESULT( 6 ) = ZERO * IF( N.GT.CRANK ) - $ RESULT( 10 ) = SQRT14( 'No transpose', M, N, - $ NRHS, COPYA, LDA, B, LDB, - $ WORK, LWORK ) + $ RESULT( 6 ) = SQRT14( 'No transpose', M, N, + $ NRHS, COPYA, LDA, B, LDB, + $ WORK, LWORK ) * * Test SGELSS * @@ -600,38 +528,38 @@ * workspace used: 3*min(m,n) + * max(2*min(m,n),nrhs,max(m,n)) * -* Test 11: Compute relative error in svd +* Test 7: Compute relative error in svd * IF( RANK.GT.0 ) THEN CALL SAXPY( MNMIN, -ONE, COPYS, 1, S, 1 ) - RESULT( 11 ) = SASUM( MNMIN, S, 1 ) / - $ SASUM( MNMIN, COPYS, 1 ) / - $ ( EPS*REAL( MNMIN ) ) + RESULT( 7 ) = SASUM( MNMIN, S, 1 ) / + $ SASUM( MNMIN, COPYS, 1 ) / + $ ( EPS*REAL( MNMIN ) ) ELSE - RESULT( 11 ) = ZERO + RESULT( 7 ) = ZERO END IF * -* Test 12: Compute error in solution +* Test 8: Compute error in solution * CALL SLACPY( 'Full', M, NRHS, COPYB, LDB, WORK, $ LDWORK ) CALL SQRT16( 'No transpose', M, N, NRHS, COPYA, $ LDA, B, LDB, WORK, LDWORK, - $ WORK( M*NRHS+1 ), RESULT( 12 ) ) + $ WORK( M*NRHS+1 ), RESULT( 8 ) ) * -* Test 13: Check norm of r'*A +* Test 9: Check norm of r'*A * - RESULT( 13 ) = ZERO + RESULT( 9 ) = ZERO IF( M.GT.CRANK ) - $ RESULT( 13 ) = SQRT17( 'No transpose', 1, M, - $ N, NRHS, COPYA, LDA, B, LDB, - $ COPYB, LDB, C, WORK, LWORK ) + $ RESULT( 9 ) = SQRT17( 'No transpose', 1, M, + $ N, NRHS, COPYA, LDA, B, LDB, + $ COPYB, LDB, C, WORK, LWORK ) * -* Test 14: Check if x is in the rowspace of A +* Test 10: Check if x is in the rowspace of A * - RESULT( 14 ) = ZERO + RESULT( 10 ) = ZERO IF( N.GT.CRANK ) - $ RESULT( 14 ) = SQRT14( 'No transpose', M, N, + $ RESULT( 10 ) = SQRT14( 'No transpose', M, N, $ NRHS, COPYA, LDA, B, LDB, $ WORK, LWORK ) * @@ -660,45 +588,45 @@ $ N, NRHS, -1, NB, ITYPE, NFAIL, $ NERRS, NOUT ) * -* Test 15: Compute relative error in svd +* Test 11: Compute relative error in svd * IF( RANK.GT.0 ) THEN CALL SAXPY( MNMIN, -ONE, COPYS, 1, S, 1 ) - RESULT( 15 ) = SASUM( MNMIN, S, 1 ) / + RESULT( 11 ) = SASUM( MNMIN, S, 1 ) / $ SASUM( MNMIN, COPYS, 1 ) / $ ( EPS*REAL( MNMIN ) ) ELSE - RESULT( 15 ) = ZERO + RESULT( 11 ) = ZERO END IF * -* Test 16: Compute error in solution +* Test 12: Compute error in solution * CALL SLACPY( 'Full', M, NRHS, COPYB, LDB, WORK, $ LDWORK ) CALL SQRT16( 'No transpose', M, N, NRHS, COPYA, $ LDA, B, LDB, WORK, LDWORK, - $ WORK( M*NRHS+1 ), RESULT( 16 ) ) + $ WORK( M*NRHS+1 ), RESULT( 12 ) ) * -* Test 17: Check norm of r'*A +* Test 13: Check norm of r'*A * - RESULT( 17 ) = ZERO + RESULT( 13 ) = ZERO IF( M.GT.CRANK ) - $ RESULT( 17 ) = SQRT17( 'No transpose', 1, M, + $ RESULT( 13 ) = SQRT17( 'No transpose', 1, M, $ N, NRHS, COPYA, LDA, B, LDB, $ COPYB, LDB, C, WORK, LWORK ) * -* Test 18: Check if x is in the rowspace of A +* Test 14: Check if x is in the rowspace of A * - RESULT( 18 ) = ZERO + RESULT( 14 ) = ZERO IF( N.GT.CRANK ) - $ RESULT( 18 ) = SQRT14( 'No transpose', M, N, + $ RESULT( 14 ) = SQRT14( 'No transpose', M, N, $ NRHS, COPYA, LDA, B, LDB, $ WORK, LWORK ) * * Print information about the tests that did not * pass the threshold. * - DO 90 K = 7, NTESTS + DO 90 K = 3, NTESTS IF( RESULT( K ).GE.THRESH ) THEN IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) $ CALL ALAHD( NOUT, PATH ) diff --git a/TESTING/LIN/serrls.f b/TESTING/LIN/serrls.f index 7829a5e2..57a23c39 100644 --- a/TESTING/LIN/serrls.f +++ b/TESTING/LIN/serrls.f @@ -22,7 +22,7 @@ *> \verbatim *> *> SERRLS tests the error exits for the REAL least squares -*> driver routines (SGELS, SGELSS, SGELSX, SGELSY, SGELSD). +*> driver routines (SGELS, SGELSS, SGELSY, SGELSD). *> \endverbatim * * Arguments: @@ -86,8 +86,7 @@ EXTERNAL LSAMEN * .. * .. External Subroutines .. - EXTERNAL ALAESM, CHKXER, SGELS, SGELSD, SGELSS, SGELSX, - $ SGELSY + EXTERNAL ALAESM, CHKXER, SGELS, SGELSD, SGELSS, SGELSY * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -157,25 +156,6 @@ CALL SGELSS( 2, 0, 0, A, 2, B, 1, S, RCOND, IRNK, W, 2, INFO ) CALL CHKXER( 'SGELSS', INFOT, NOUT, LERR, OK ) * -* SGELSX -* - SRNAMT = 'SGELSX' - INFOT = 1 - CALL SGELSX( -1, 0, 0, A, 1, B, 1, IP, RCOND, IRNK, W, INFO ) - CALL CHKXER( 'SGELSX', INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL SGELSX( 0, -1, 0, A, 1, B, 1, IP, RCOND, IRNK, W, INFO ) - CALL CHKXER( 'SGELSX', INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL SGELSX( 0, 0, -1, A, 1, B, 1, IP, RCOND, IRNK, W, INFO ) - CALL CHKXER( 'SGELSX', INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL SGELSX( 2, 0, 0, A, 1, B, 2, IP, RCOND, IRNK, W, INFO ) - CALL CHKXER( 'SGELSX', INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL SGELSX( 2, 0, 0, A, 2, B, 1, IP, RCOND, IRNK, W, INFO ) - CALL CHKXER( 'SGELSX', INFOT, NOUT, LERR, OK ) -* * SGELSY * SRNAMT = 'SGELSY' diff --git a/TESTING/LIN/serrtz.f b/TESTING/LIN/serrtz.f index db03b0ad..391df973 100644 --- a/TESTING/LIN/serrtz.f +++ b/TESTING/LIN/serrtz.f @@ -21,7 +21,7 @@ *> *> \verbatim *> -*> SERRTZ tests the error exits for STZRQF and STZRZF. +*> SERRTZ tests the error exits for STZRZF. *> \endverbatim * * Arguments: @@ -82,7 +82,7 @@ EXTERNAL LSAMEN * .. * .. External Subroutines .. - EXTERNAL ALAESM, CHKXER, STZRQF, STZRZF + EXTERNAL ALAESM, CHKXER, STZRZF * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -110,19 +110,6 @@ * * Test error exits for the trapezoidal routines. * -* STZRQF -* - SRNAMT = 'STZRQF' - INFOT = 1 - CALL STZRQF( -1, 0, A, 1, TAU, INFO ) - CALL CHKXER( 'STZRQF', INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL STZRQF( 1, 0, A, 1, TAU, INFO ) - CALL CHKXER( 'STZRQF', INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL STZRQF( 2, 2, A, 1, TAU, INFO ) - CALL CHKXER( 'STZRQF', INFOT, NOUT, LERR, OK ) -* * STZRZF * SRNAMT = 'STZRZF' diff --git a/TESTING/LIN/stzt01.f b/TESTING/LIN/stzt01.f deleted file mode 100644 index 406af5ac..00000000 --- a/TESTING/LIN/stzt01.f +++ /dev/null @@ -1,186 +0,0 @@ -*> \brief \b STZT01 -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* REAL FUNCTION STZT01( M, N, A, AF, LDA, TAU, WORK, -* LWORK ) -* -* .. Scalar Arguments .. -* INTEGER LDA, LWORK, M, N -* .. -* .. Array Arguments .. -* REAL A( LDA, * ), AF( LDA, * ), TAU( * ), -* $ WORK( LWORK ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> STZT01 returns -*> || A - R*Q || / ( M * eps * ||A|| ) -*> for an upper trapezoidal A that was factored with STZRQF. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the matrices A and AF. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the matrices A and AF. -*> \endverbatim -*> -*> \param[in] A -*> \verbatim -*> A is REAL array, dimension (LDA,N) -*> The original upper trapezoidal M by N matrix A. -*> \endverbatim -*> -*> \param[in] AF -*> \verbatim -*> AF is REAL array, dimension (LDA,N) -*> The output of STZRQF for input matrix A. -*> The lower triangle is not referenced. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the arrays A and AF. -*> \endverbatim -*> -*> \param[in] TAU -*> \verbatim -*> TAU is REAL array, dimension (M) -*> Details of the Householder transformations as returned by -*> STZRQF. -*> \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 >= m*n + m. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date November 2011 -* -*> \ingroup single_lin -* -* ===================================================================== - REAL FUNCTION STZT01( M, N, A, AF, LDA, TAU, WORK, - $ LWORK ) -* -* -- 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 .. - INTEGER LDA, LWORK, M, N -* .. -* .. Array Arguments .. - REAL A( LDA, * ), AF( LDA, * ), TAU( * ), - $ WORK( LWORK ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - REAL ZERO, ONE - PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 ) -* .. -* .. Local Scalars .. - INTEGER I, J - REAL NORMA -* .. -* .. Local Arrays .. - REAL RWORK( 1 ) -* .. -* .. External Functions .. - REAL SLAMCH, SLANGE - EXTERNAL SLAMCH, SLANGE -* .. -* .. External Subroutines .. - EXTERNAL SAXPY, SLATZM, SLASET, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, REAL -* .. -* .. Executable Statements .. -* - STZT01 = ZERO -* - IF( LWORK.LT.M*N+M ) THEN - CALL XERBLA( 'STZT01', 8 ) - RETURN - END IF -* -* Quick return if possible -* - IF( M.LE.0 .OR. N.LE.0 ) - $ RETURN -* - NORMA = SLANGE( 'One-norm', M, N, A, LDA, RWORK ) -* -* Copy upper triangle R -* - CALL SLASET( 'Full', M, N, ZERO, ZERO, WORK, M ) - DO 20 J = 1, M - DO 10 I = 1, J - WORK( ( J-1 )*M+I ) = AF( I, J ) - 10 CONTINUE - 20 CONTINUE -* -* R = R * P(1) * ... *P(m) -* - DO 30 I = 1, M - CALL SLATZM( 'Right', I, N-M+1, AF( I, M+1 ), LDA, TAU( I ), - $ WORK( ( I-1 )*M+1 ), WORK( M*M+1 ), M, - $ WORK( M*N+1 ) ) - 30 CONTINUE -* -* R = R - A -* - DO 40 I = 1, N - CALL SAXPY( M, -ONE, A( 1, I ), 1, WORK( ( I-1 )*M+1 ), 1 ) - 40 CONTINUE -* - STZT01 = SLANGE( 'One-norm', M, N, WORK, M, RWORK ) -* - STZT01 = STZT01 / ( SLAMCH( 'Epsilon' )*REAL( MAX( M, N ) ) ) - IF( NORMA.NE.ZERO ) - $ STZT01 = STZT01 / NORMA -* - RETURN -* -* End of STZT01 -* - END diff --git a/TESTING/LIN/stzt02.f b/TESTING/LIN/stzt02.f deleted file mode 100644 index fea6770b..00000000 --- a/TESTING/LIN/stzt02.f +++ /dev/null @@ -1,172 +0,0 @@ -*> \brief \b STZT02 -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* REAL FUNCTION STZT02( M, N, AF, LDA, TAU, WORK, -* LWORK ) -* -* .. Scalar Arguments .. -* INTEGER LDA, LWORK, M, N -* .. -* .. Array Arguments .. -* REAL AF( LDA, * ), TAU( * ), WORK( LWORK ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> STZT02 returns -*> || I - Q'*Q || / ( M * eps) -*> where the matrix Q is defined by the Householder transformations -*> generated by STZRQF. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the matrix AF. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the matrix AF. -*> \endverbatim -*> -*> \param[in] AF -*> \verbatim -*> AF is REAL array, dimension (LDA,N) -*> The output of STZRQF. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array AF. -*> \endverbatim -*> -*> \param[in] TAU -*> \verbatim -*> TAU is REAL array, dimension (M) -*> Details of the Householder transformations as returned by -*> STZRQF. -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is REAL array, dimension (LWORK) -*> \endverbatim -*> -*> \param[in] LWORK -*> \verbatim -*> LWORK is INTEGER -*> length of WORK array. Must be >= N*N+N -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date November 2011 -* -*> \ingroup single_lin -* -* ===================================================================== - REAL FUNCTION STZT02( M, N, AF, LDA, TAU, WORK, - $ LWORK ) -* -* -- 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 .. - INTEGER LDA, LWORK, M, N -* .. -* .. Array Arguments .. - REAL AF( LDA, * ), TAU( * ), WORK( LWORK ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - REAL ZERO, ONE - PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 ) -* .. -* .. Local Scalars .. - INTEGER I -* .. -* .. Local Arrays .. - REAL RWORK( 1 ) -* .. -* .. External Functions .. - REAL SLAMCH, SLANGE - EXTERNAL SLAMCH, SLANGE -* .. -* .. External Subroutines .. - EXTERNAL SLATZM, SLASET, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, REAL -* .. -* .. Executable Statements .. -* - STZT02 = ZERO -* - IF( LWORK.LT.N*N+N ) THEN - CALL XERBLA( 'STZT02', 7 ) - RETURN - END IF -* -* Quick return if possible -* - IF( M.LE.0 .OR. N.LE.0 ) - $ RETURN -* -* Q := I -* - CALL SLASET( 'Full', N, N, ZERO, ONE, WORK, N ) -* -* Q := P(1) * ... * P(m) * Q -* - DO 10 I = M, 1, -1 - CALL SLATZM( 'Left', N-M+1, N, AF( I, M+1 ), LDA, TAU( I ), - $ WORK( I ), WORK( M+1 ), N, WORK( N*N+1 ) ) - 10 CONTINUE -* -* Q := P(m) * ... * P(1) * Q -* - DO 20 I = 1, M - CALL SLATZM( 'Left', N-M+1, N, AF( I, M+1 ), LDA, TAU( I ), - $ WORK( I ), WORK( M+1 ), N, WORK( N*N+1 ) ) - 20 CONTINUE -* -* Q := Q - I -* - DO 30 I = 1, N - WORK( ( I-1 )*N+I ) = WORK( ( I-1 )*N+I ) - ONE - 30 CONTINUE -* - STZT02 = SLANGE( 'One-norm', N, N, WORK, N, RWORK ) / - $ ( SLAMCH( 'Epsilon' )*REAL( MAX( M, N ) ) ) - RETURN -* -* End of STZT02 -* - END diff --git a/TESTING/LIN/zchktz.f b/TESTING/LIN/zchktz.f index 56bf937c..91d0e6b2 100644 --- a/TESTING/LIN/zchktz.f +++ b/TESTING/LIN/zchktz.f @@ -29,7 +29,7 @@ *> *> \verbatim *> -*> ZCHKTZ tests ZTZRQF and ZTZRZF. +*> ZCHKTZ tests ZTZRZF. *> \endverbatim * * Arguments: @@ -160,7 +160,7 @@ INTEGER NTYPES PARAMETER ( NTYPES = 3 ) INTEGER NTESTS - PARAMETER ( NTESTS = 6 ) + PARAMETER ( NTESTS = 3 ) DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) * .. @@ -175,12 +175,12 @@ DOUBLE PRECISION RESULT( NTESTS ) * .. * .. External Functions .. - DOUBLE PRECISION DLAMCH, ZQRT12, ZRZT01, ZRZT02, ZTZT01, ZTZT02 - EXTERNAL DLAMCH, ZQRT12, ZRZT01, ZRZT02, ZTZT01, ZTZT02 + DOUBLE PRECISION DLAMCH, ZQRT12, ZRZT01, ZRZT02 + EXTERNAL DLAMCH, ZQRT12, ZRZT01, ZRZT02 * .. * .. External Subroutines .. EXTERNAL ALAHD, ALASUM, DLAORD, ZERRTZ, ZGEQR2, ZLACPY, - $ ZLASET, ZLATMS, ZTZRQF, ZTZRZF + $ ZLASET, ZLATMS, ZTZRZF * .. * .. Intrinsic Functions .. INTRINSIC DCMPLX, MAX, MIN @@ -252,53 +252,6 @@ IF( MODE.EQ.0 ) THEN CALL ZLASET( 'Full', M, N, DCMPLX( ZERO ), $ DCMPLX( ZERO ), A, LDA ) - DO 20 I = 1, MNMIN - S( I ) = ZERO - 20 CONTINUE - ELSE - CALL ZLATMS( M, N, 'Uniform', ISEED, - $ 'Nonsymmetric', S, IMODE, - $ ONE / EPS, ONE, M, N, 'No packing', A, - $ LDA, WORK, INFO ) - CALL ZGEQR2( M, N, A, LDA, WORK, WORK( MNMIN+1 ), - $ INFO ) - CALL ZLASET( 'Lower', M-1, N, DCMPLX( ZERO ), - $ DCMPLX( ZERO ), A( 2 ), LDA ) - CALL DLAORD( 'Decreasing', MNMIN, S, 1 ) - END IF -* -* Save A and its singular values -* - CALL ZLACPY( 'All', M, N, A, LDA, COPYA, LDA ) -* -* Call ZTZRQF to reduce the upper trapezoidal matrix to -* upper triangular form. -* - SRNAMT = 'ZTZRQF' - CALL ZTZRQF( M, N, A, LDA, TAU, INFO ) -* -* Compute norm(svd(a) - svd(r)) -* - RESULT( 1 ) = ZQRT12( M, M, A, LDA, S, WORK, - $ LWORK, RWORK ) -* -* Compute norm( A - R*Q ) -* - RESULT( 2 ) = ZTZT01( M, N, COPYA, A, LDA, TAU, WORK, - $ LWORK ) -* -* Compute norm(Q'*Q - I). -* - RESULT( 3 ) = ZTZT02( M, N, A, LDA, TAU, WORK, LWORK ) -* -* Test ZTZRZF -* -* Generate test matrix of size m by n using -* singular value distribution indicated by `mode'. -* - IF( MODE.EQ.0 ) THEN - CALL ZLASET( 'Full', M, N, DCMPLX( ZERO ), - $ DCMPLX( ZERO ), A, LDA ) DO 30 I = 1, MNMIN S( I ) = ZERO 30 CONTINUE @@ -326,22 +279,22 @@ * * Compute norm(svd(a) - svd(r)) * - RESULT( 4 ) = ZQRT12( M, M, A, LDA, S, WORK, + RESULT( 1 ) = ZQRT12( M, M, A, LDA, S, WORK, $ LWORK, RWORK ) * * Compute norm( A - R*Q ) * - RESULT( 5 ) = ZRZT01( M, N, COPYA, A, LDA, TAU, WORK, + RESULT( 2 ) = ZRZT01( M, N, COPYA, A, LDA, TAU, WORK, $ LWORK ) * * Compute norm(Q'*Q - I). * - RESULT( 6 ) = ZRZT02( M, N, A, LDA, TAU, WORK, LWORK ) + RESULT( 3 ) = ZRZT02( M, N, A, LDA, TAU, WORK, LWORK ) * * Print information about the tests that did not pass * the threshold. * - DO 40 K = 1, 6 + DO 40 K = 1, NTESTS IF( RESULT( K ).GE.THRESH ) THEN IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) $ CALL ALAHD( NOUT, PATH ) @@ -350,7 +303,7 @@ NFAIL = NFAIL + 1 END IF 40 CONTINUE - NRUN = NRUN + 6 + NRUN = NRUN + 3 50 CONTINUE END IF 60 CONTINUE diff --git a/TESTING/LIN/zdrvls.f b/TESTING/LIN/zdrvls.f index af9608e4..680b76dd 100644 --- a/TESTING/LIN/zdrvls.f +++ b/TESTING/LIN/zdrvls.f @@ -32,8 +32,8 @@ *> *> \verbatim *> -*> ZDRVLS tests the least squares driver routines ZGELS, CGELSX, CGELSS, -*> ZGELSY and CGELSD. +*> ZDRVLS tests the least squares driver routines ZGELS, CGELSS, ZGELSY +*> and CGELSD. *> \endverbatim * * Arguments: @@ -232,7 +232,7 @@ * * .. Parameters .. INTEGER NTESTS - PARAMETER ( NTESTS = 18 ) + PARAMETER ( NTESTS = 14 ) INTEGER SMLSIZ PARAMETER ( SMLSIZ = 25 ) DOUBLE PRECISION ONE, ZERO @@ -260,7 +260,7 @@ * .. * .. External Subroutines .. EXTERNAL ALAERH, ALAHD, ALASVM, DAXPY, DLASRT, XLAENV, - $ ZDSCAL, ZERRLS, ZGELS, ZGELSD, ZGELSS, ZGELSX, + $ ZDSCAL, ZERRLS, ZGELS, ZGELSD, ZGELSS, $ ZGELSY, ZGEMM, ZLACPY, ZLARNV, ZQRT13, ZQRT15, $ ZQRT16 * .. @@ -442,79 +442,8 @@ * * workspace used: MAX(M+MIN(M,N),NRHS*MIN(M,N),2*N+M) * - DO 50 J = 1, N - IWORK( J ) = 0 - 50 CONTINUE LDWORK = MAX( 1, M ) * -* Test ZGELSX -* -* ZGELSX: Compute the minimum-norm solution X -* to min( norm( A * X - B ) ) -* using a complete orthogonal factorization. -* - CALL ZLACPY( 'Full', M, N, COPYA, LDA, A, LDA ) - CALL ZLACPY( 'Full', M, NRHS, COPYB, LDB, B, LDB ) -* - SRNAMT = 'ZGELSX' - CALL ZGELSX( M, N, NRHS, A, LDA, B, LDB, IWORK, - $ RCOND, CRANK, WORK, RWORK, INFO ) -* - IF( INFO.NE.0 ) - $ CALL ALAERH( PATH, 'ZGELSX', INFO, 0, ' ', M, N, - $ NRHS, -1, NB, ITYPE, NFAIL, NERRS, - $ NOUT ) -* -* workspace used: MAX( MNMIN+3*N, 2*MNMIN+NRHS ) -* -* Test 3: Compute relative error in svd -* workspace: M*N + 4*MIN(M,N) + MAX(M,N) -* - RESULT( 3 ) = ZQRT12( CRANK, CRANK, A, LDA, COPYS, - $ WORK, LWORK, RWORK ) -* -* Test 4: Compute error in solution -* workspace: M*NRHS + M -* - CALL ZLACPY( 'Full', M, NRHS, COPYB, LDB, WORK, - $ LDWORK ) - CALL ZQRT16( 'No transpose', M, N, NRHS, COPYA, - $ LDA, B, LDB, WORK, LDWORK, RWORK, - $ RESULT( 4 ) ) -* -* Test 5: Check norm of r'*A -* workspace: NRHS*(M+N) -* - RESULT( 5 ) = ZERO - IF( M.GT.CRANK ) - $ RESULT( 5 ) = ZQRT17( 'No transpose', 1, M, N, - $ NRHS, COPYA, LDA, B, LDB, COPYB, - $ LDB, C, WORK, LWORK ) -* -* Test 6: Check if x is in the rowspace of A -* workspace: (M+NRHS)*(N+2) -* - RESULT( 6 ) = ZERO -* - IF( N.GT.CRANK ) - $ RESULT( 6 ) = ZQRT14( 'No transpose', M, N, - $ NRHS, COPYA, LDA, B, LDB, WORK, - $ LWORK ) -* -* Print information about the tests that did not -* pass the threshold. -* - DO 60 K = 3, 6 - IF( RESULT( K ).GE.THRESH ) THEN - IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) - $ CALL ALAHD( NOUT, PATH ) - WRITE( NOUT, FMT = 9998 )M, N, NRHS, 0, - $ ITYPE, K, RESULT( K ) - NFAIL = NFAIL + 1 - END IF - 60 CONTINUE - NRUN = NRUN + 4 -* * Loop for testing different block sizes. * DO 90 INB = 1, NNB @@ -556,39 +485,39 @@ * * workspace used: 2*MNMIN+NB*NB+NB*MAX(N,NRHS) * -* Test 7: Compute relative error in svd +* Test 3: Compute relative error in svd * workspace: M*N + 4*MIN(M,N) + MAX(M,N) * - RESULT( 7 ) = ZQRT12( CRANK, CRANK, A, LDA, + RESULT( 3 ) = ZQRT12( CRANK, CRANK, A, LDA, $ COPYS, WORK, LWORK, RWORK ) * -* Test 8: Compute error in solution +* Test 4: Compute error in solution * workspace: M*NRHS + M * CALL ZLACPY( 'Full', M, NRHS, COPYB, LDB, WORK, $ LDWORK ) CALL ZQRT16( 'No transpose', M, N, NRHS, COPYA, $ LDA, B, LDB, WORK, LDWORK, RWORK, - $ RESULT( 8 ) ) + $ RESULT( 4 ) ) * -* Test 9: Check norm of r'*A +* Test 5: Check norm of r'*A * workspace: NRHS*(M+N) * - RESULT( 9 ) = ZERO + RESULT( 5 ) = ZERO IF( M.GT.CRANK ) - $ RESULT( 9 ) = ZQRT17( 'No transpose', 1, M, + $ RESULT( 5 ) = ZQRT17( 'No transpose', 1, M, $ N, NRHS, COPYA, LDA, B, LDB, $ COPYB, LDB, C, WORK, LWORK ) * -* Test 10: Check if x is in the rowspace of A +* Test 6: Check if x is in the rowspace of A * workspace: (M+NRHS)*(N+2) * - RESULT( 10 ) = ZERO + RESULT( 6 ) = ZERO * IF( N.GT.CRANK ) - $ RESULT( 10 ) = ZQRT14( 'No transpose', M, N, - $ NRHS, COPYA, LDA, B, LDB, - $ WORK, LWORK ) + $ RESULT( 6 ) = ZQRT14( 'No transpose', M, N, + $ NRHS, COPYA, LDA, B, LDB, + $ WORK, LWORK ) * * Test ZGELSS * @@ -612,38 +541,38 @@ * workspace used: 3*min(m,n) + * max(2*min(m,n),nrhs,max(m,n)) * -* Test 11: Compute relative error in svd +* Test 7: Compute relative error in svd * IF( RANK.GT.0 ) THEN CALL DAXPY( MNMIN, -ONE, COPYS, 1, S, 1 ) - RESULT( 11 ) = DASUM( MNMIN, S, 1 ) / - $ DASUM( MNMIN, COPYS, 1 ) / - $ ( EPS*DBLE( MNMIN ) ) + RESULT( 7 ) = DASUM( MNMIN, S, 1 ) / + $ DASUM( MNMIN, COPYS, 1 ) / + $ ( EPS*DBLE( MNMIN ) ) ELSE - RESULT( 11 ) = ZERO + RESULT( 7 ) = ZERO END IF * -* Test 12: Compute error in solution +* Test 8: Compute error in solution * CALL ZLACPY( 'Full', M, NRHS, COPYB, LDB, WORK, $ LDWORK ) CALL ZQRT16( 'No transpose', M, N, NRHS, COPYA, $ LDA, B, LDB, WORK, LDWORK, RWORK, - $ RESULT( 12 ) ) + $ RESULT( 8 ) ) * -* Test 13: Check norm of r'*A +* Test 9: Check norm of r'*A * - RESULT( 13 ) = ZERO + RESULT( 9 ) = ZERO IF( M.GT.CRANK ) - $ RESULT( 13 ) = ZQRT17( 'No transpose', 1, M, - $ N, NRHS, COPYA, LDA, B, LDB, - $ COPYB, LDB, C, WORK, LWORK ) + $ RESULT( 9 ) = ZQRT17( 'No transpose', 1, M, + $ N, NRHS, COPYA, LDA, B, LDB, + $ COPYB, LDB, C, WORK, LWORK ) * -* Test 14: Check if x is in the rowspace of A +* Test 10: Check if x is in the rowspace of A * - RESULT( 14 ) = ZERO + RESULT( 10 ) = ZERO IF( N.GT.CRANK ) - $ RESULT( 14 ) = ZQRT14( 'No transpose', M, N, + $ RESULT( 10 ) = ZQRT14( 'No transpose', M, N, $ NRHS, COPYA, LDA, B, LDB, $ WORK, LWORK ) * @@ -668,45 +597,45 @@ $ N, NRHS, -1, NB, ITYPE, NFAIL, $ NERRS, NOUT ) * -* Test 15: Compute relative error in svd +* Test 11: Compute relative error in svd * IF( RANK.GT.0 ) THEN CALL DAXPY( MNMIN, -ONE, COPYS, 1, S, 1 ) - RESULT( 15 ) = DASUM( MNMIN, S, 1 ) / + RESULT( 11 ) = DASUM( MNMIN, S, 1 ) / $ DASUM( MNMIN, COPYS, 1 ) / $ ( EPS*DBLE( MNMIN ) ) ELSE - RESULT( 15 ) = ZERO + RESULT( 11 ) = ZERO END IF * -* Test 16: Compute error in solution +* Test 12: Compute error in solution * CALL ZLACPY( 'Full', M, NRHS, COPYB, LDB, WORK, $ LDWORK ) CALL ZQRT16( 'No transpose', M, N, NRHS, COPYA, $ LDA, B, LDB, WORK, LDWORK, RWORK, - $ RESULT( 16 ) ) + $ RESULT( 12 ) ) * -* Test 17: Check norm of r'*A +* Test 13: Check norm of r'*A * - RESULT( 17 ) = ZERO + RESULT( 13 ) = ZERO IF( M.GT.CRANK ) - $ RESULT( 17 ) = ZQRT17( 'No transpose', 1, M, + $ RESULT( 13 ) = ZQRT17( 'No transpose', 1, M, $ N, NRHS, COPYA, LDA, B, LDB, $ COPYB, LDB, C, WORK, LWORK ) * -* Test 18: Check if x is in the rowspace of A +* Test 14: Check if x is in the rowspace of A * - RESULT( 18 ) = ZERO + RESULT( 14 ) = ZERO IF( N.GT.CRANK ) - $ RESULT( 18 ) = ZQRT14( 'No transpose', M, N, + $ RESULT( 14 ) = ZQRT14( 'No transpose', M, N, $ NRHS, COPYA, LDA, B, LDB, $ WORK, LWORK ) * * Print information about the tests that did not * pass the threshold. * - DO 80 K = 7, NTESTS + DO 80 K = 3, NTESTS IF( RESULT( K ).GE.THRESH ) THEN IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) $ CALL ALAHD( NOUT, PATH ) diff --git a/TESTING/LIN/zerrls.f b/TESTING/LIN/zerrls.f index e457befd..6fa7e150 100644 --- a/TESTING/LIN/zerrls.f +++ b/TESTING/LIN/zerrls.f @@ -22,7 +22,7 @@ *> \verbatim *> *> ZERRLS tests the error exits for the COMPLEX*16 least squares -*> driver routines (ZGELS, CGELSS, CGELSX, CGELSY, CGELSD). +*> driver routines (ZGELS, CGELSS, CGELSY, CGELSD). *> \endverbatim * * Arguments: @@ -86,8 +86,7 @@ EXTERNAL LSAMEN * .. * .. External Subroutines .. - EXTERNAL ALAESM, CHKXER, ZGELS, ZGELSD, ZGELSS, ZGELSX, - $ ZGELSY + EXTERNAL ALAESM, CHKXER, ZGELS, ZGELSD, ZGELSS, ZGELSY * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -162,30 +161,6 @@ $ INFO ) CALL CHKXER( 'ZGELSS', INFOT, NOUT, LERR, OK ) * -* ZGELSX -* - SRNAMT = 'ZGELSX' - INFOT = 1 - CALL ZGELSX( -1, 0, 0, A, 1, B, 1, IP, RCOND, IRNK, W, RW, - $ INFO ) - CALL CHKXER( 'ZGELSX', INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL ZGELSX( 0, -1, 0, A, 1, B, 1, IP, RCOND, IRNK, W, RW, - $ INFO ) - CALL CHKXER( 'ZGELSX', INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL ZGELSX( 0, 0, -1, A, 1, B, 1, IP, RCOND, IRNK, W, RW, - $ INFO ) - CALL CHKXER( 'ZGELSX', INFOT, NOUT, LERR, OK ) - INFOT = 5 - CALL ZGELSX( 2, 0, 0, A, 1, B, 2, IP, RCOND, IRNK, W, RW, - $ INFO ) - CALL CHKXER( 'ZGELSX', INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL ZGELSX( 2, 0, 0, A, 2, B, 1, IP, RCOND, IRNK, W, RW, - $ INFO ) - CALL CHKXER( 'ZGELSX', INFOT, NOUT, LERR, OK ) -* * ZGELSY * SRNAMT = 'ZGELSY' diff --git a/TESTING/LIN/zerrtz.f b/TESTING/LIN/zerrtz.f index 7566d5c1..0c03aae7 100644 --- a/TESTING/LIN/zerrtz.f +++ b/TESTING/LIN/zerrtz.f @@ -21,7 +21,7 @@ *> *> \verbatim *> -*> ZERRTZ tests the error exits for ZTZRQF and ZTZRZF. +*> ZERRTZ tests the error exits for ZTZRZF. *> \endverbatim * * Arguments: @@ -82,7 +82,7 @@ EXTERNAL LSAMEN * .. * .. External Subroutines .. - EXTERNAL ALAESM, CHKXER, ZTZRQF, ZTZRZF + EXTERNAL ALAESM, CHKXER, ZTZRZF * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -109,22 +109,9 @@ OK = .TRUE. * * Test error exits for the trapezoidal routines. -* WRITE( NOUT, FMT = * ) IF( LSAMEN( 2, C2, 'TZ' ) ) THEN * -* ZTZRQF -* - SRNAMT = 'ZTZRQF' - INFOT = 1 - CALL ZTZRQF( -1, 0, A, 1, TAU, INFO ) - CALL CHKXER( 'ZTZRQF', INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL ZTZRQF( 1, 0, A, 1, TAU, INFO ) - CALL CHKXER( 'ZTZRQF', INFOT, NOUT, LERR, OK ) - INFOT = 4 - CALL ZTZRQF( 2, 2, A, 1, TAU, INFO ) - CALL CHKXER( 'ZTZRQF', INFOT, NOUT, LERR, OK ) * * ZTZRZF * diff --git a/TESTING/LIN/ztzt01.f b/TESTING/LIN/ztzt01.f deleted file mode 100644 index 26de320c..00000000 --- a/TESTING/LIN/ztzt01.f +++ /dev/null @@ -1,188 +0,0 @@ -*> \brief \b ZTZT01 -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* DOUBLE PRECISION FUNCTION ZTZT01( M, N, A, AF, LDA, TAU, WORK, -* LWORK ) -* -* .. Scalar Arguments .. -* INTEGER LDA, LWORK, M, N -* .. -* .. Array Arguments .. -* COMPLEX*16 A( LDA, * ), AF( LDA, * ), TAU( * ), -* $ WORK( LWORK ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZTZT01 returns -*> || A - R*Q || / ( M * eps * ||A|| ) -*> for an upper trapezoidal A that was factored with ZTZRQF. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the matrices A and AF. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the matrices A and AF. -*> \endverbatim -*> -*> \param[in] A -*> \verbatim -*> A is COMPLEX*16 array, dimension (LDA,N) -*> The original upper trapezoidal M by N matrix A. -*> \endverbatim -*> -*> \param[in] AF -*> \verbatim -*> AF is COMPLEX*16 array, dimension (LDA,N) -*> The output of ZTZRQF for input matrix A. -*> The lower triangle is not referenced. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the arrays A and AF. -*> \endverbatim -*> -*> \param[in] TAU -*> \verbatim -*> TAU is COMPLEX*16 array, dimension (M) -*> Details of the Householder transformations as returned by -*> ZTZRQF. -*> \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 >= m*n + m. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date November 2011 -* -*> \ingroup complex16_lin -* -* ===================================================================== - DOUBLE PRECISION FUNCTION ZTZT01( M, N, A, AF, LDA, TAU, WORK, - $ LWORK ) -* -* -- 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 .. - INTEGER LDA, LWORK, M, N -* .. -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), AF( LDA, * ), TAU( * ), - $ WORK( LWORK ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -* .. -* .. Local Scalars .. - INTEGER I, J - DOUBLE PRECISION NORMA -* .. -* .. Local Arrays .. - DOUBLE PRECISION RWORK( 1 ) -* .. -* .. External Functions .. - DOUBLE PRECISION DLAMCH, ZLANGE - EXTERNAL DLAMCH, ZLANGE -* .. -* .. External Subroutines .. - EXTERNAL XERBLA, ZAXPY, ZLASET, ZLATZM -* .. -* .. Intrinsic Functions .. - INTRINSIC DBLE, DCMPLX, MAX -* .. -* .. Executable Statements .. -* - ZTZT01 = ZERO -* - IF( LWORK.LT.M*N+M ) THEN - CALL XERBLA( 'ZTZT01', 8 ) - RETURN - END IF -* -* Quick return if possible -* - IF( M.LE.0 .OR. N.LE.0 ) - $ RETURN -* - NORMA = ZLANGE( 'One-norm', M, N, A, LDA, RWORK ) -* -* Copy upper triangle R -* - CALL ZLASET( 'Full', M, N, DCMPLX( ZERO ), DCMPLX( ZERO ), WORK, - $ M ) - DO 20 J = 1, M - DO 10 I = 1, J - WORK( ( J-1 )*M+I ) = AF( I, J ) - 10 CONTINUE - 20 CONTINUE -* -* R = R * P(1) * ... *P(m) -* - DO 30 I = 1, M - CALL ZLATZM( 'Right', I, N-M+1, AF( I, M+1 ), LDA, TAU( I ), - $ WORK( ( I-1 )*M+1 ), WORK( M*M+1 ), M, - $ WORK( M*N+1 ) ) - 30 CONTINUE -* -* R = R - A -* - DO 40 I = 1, N - CALL ZAXPY( M, DCMPLX( -ONE ), A( 1, I ), 1, - $ WORK( ( I-1 )*M+1 ), 1 ) - 40 CONTINUE -* - ZTZT01 = ZLANGE( 'One-norm', M, N, WORK, M, RWORK ) -* - ZTZT01 = ZTZT01 / ( DLAMCH( 'Epsilon' )*DBLE( MAX( M, N ) ) ) - IF( NORMA.NE.ZERO ) - $ ZTZT01 = ZTZT01 / NORMA -* - RETURN -* -* End of ZTZT01 -* - END diff --git a/TESTING/LIN/ztzt02.f b/TESTING/LIN/ztzt02.f deleted file mode 100644 index 1d9544dd..00000000 --- a/TESTING/LIN/ztzt02.f +++ /dev/null @@ -1,174 +0,0 @@ -*> \brief \b ZTZT02 -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* DOUBLE PRECISION FUNCTION ZTZT02( M, N, AF, LDA, TAU, WORK, -* LWORK ) -* -* .. Scalar Arguments .. -* INTEGER LDA, LWORK, M, N -* .. -* .. Array Arguments .. -* COMPLEX*16 AF( LDA, * ), TAU( * ), WORK( LWORK ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZTZT02 returns -*> || I - Q'*Q || / ( M * eps) -*> where the matrix Q is defined by the Householder transformations -*> generated by ZTZRQF. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the matrix AF. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the matrix AF. -*> \endverbatim -*> -*> \param[in] AF -*> \verbatim -*> AF is COMPLEX*16 array, dimension (LDA,N) -*> The output of ZTZRQF. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array AF. -*> \endverbatim -*> -*> \param[in] TAU -*> \verbatim -*> TAU is COMPLEX*16 array, dimension (M) -*> Details of the Householder transformations as returned by -*> ZTZRQF. -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is COMPLEX*16 array, dimension (LWORK) -*> \endverbatim -*> -*> \param[in] LWORK -*> \verbatim -*> LWORK is INTEGER -*> length of WORK array. Must be >= N*N+N -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date November 2011 -* -*> \ingroup complex16_lin -* -* ===================================================================== - DOUBLE PRECISION FUNCTION ZTZT02( M, N, AF, LDA, TAU, WORK, - $ LWORK ) -* -* -- 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 .. - INTEGER LDA, LWORK, M, N -* .. -* .. Array Arguments .. - COMPLEX*16 AF( LDA, * ), TAU( * ), WORK( LWORK ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -* .. -* .. Local Scalars .. - INTEGER I -* .. -* .. Local Arrays .. - DOUBLE PRECISION RWORK( 1 ) -* .. -* .. External Functions .. - DOUBLE PRECISION DLAMCH, ZLANGE - EXTERNAL DLAMCH, ZLANGE -* .. -* .. External Subroutines .. - EXTERNAL XERBLA, ZLASET, ZLATZM -* .. -* .. Intrinsic Functions .. - INTRINSIC DBLE, DCMPLX, DCONJG, MAX -* .. -* .. Executable Statements .. -* - ZTZT02 = ZERO -* - IF( LWORK.LT.N*N+N ) THEN - CALL XERBLA( 'ZTZT02', 7 ) - RETURN - END IF -* -* Quick return if possible -* - IF( M.LE.0 .OR. N.LE.0 ) - $ RETURN -* -* Q := I -* - CALL ZLASET( 'Full', N, N, DCMPLX( ZERO ), DCMPLX( ONE ), WORK, - $ N ) -* -* Q := P(1) * ... * P(m) * Q -* - DO 10 I = M, 1, -1 - CALL ZLATZM( 'Left', N-M+1, N, AF( I, M+1 ), LDA, TAU( I ), - $ WORK( I ), WORK( M+1 ), N, WORK( N*N+1 ) ) - 10 CONTINUE -* -* Q := P(m)' * ... * P(1)' * Q -* - DO 20 I = 1, M - CALL ZLATZM( 'Left', N-M+1, N, AF( I, M+1 ), LDA, - $ DCONJG( TAU( I ) ), WORK( I ), WORK( M+1 ), N, - $ WORK( N*N+1 ) ) - 20 CONTINUE -* -* Q := Q - I -* - DO 30 I = 1, N - WORK( ( I-1 )*N+I ) = WORK( ( I-1 )*N+I ) - ONE - 30 CONTINUE -* - ZTZT02 = ZLANGE( 'One-norm', N, N, WORK, N, RWORK ) / - $ ( DLAMCH( 'Epsilon' )*DBLE( MAX( M, N ) ) ) - RETURN -* -* End of ZTZT02 -* - END |