diff options
| author | Julie <julie@cs.utk.edu> | 2016-10-23 15:53:31 -0700 |
|---|---|---|
| committer | Julie <julie@cs.utk.edu> | 2016-10-23 15:53:31 -0700 |
| commit | 84c94170b8c35f43340ba2e754eeed204fe3e55f (patch) | |
| tree | d7d26b4705b4614a8b6007f5653edde54eb3e5e5 /TESTING | |
| parent | 64f91f2de526a7ff1cf5da1ae79d172e4cd35bdb (diff) | |
| parent | a6afc403fab8bdcc4c09514ae86f3da2179d88e1 (diff) | |
Merge branch 'tsqr' of git://github.com/sydha/lapack-1 into sydha-tsqr
Diffstat (limited to 'TESTING')
55 files changed, 10727 insertions, 328 deletions
diff --git a/TESTING/.DS_Store b/TESTING/.DS_Store Binary files differnew file mode 100644 index 00000000..96586931 --- /dev/null +++ b/TESTING/.DS_Store diff --git a/TESTING/LIN/Makefile b/TESTING/LIN/Makefile index 3232f0fd..4b82e0b1 100644 --- a/TESTING/LIN/Makefile +++ b/TESTING/LIN/Makefile @@ -45,16 +45,16 @@ ALINTST = \ SCLNTST= slaord.o -DZLNTST= dlaord.o +DZLNTST= dlaord.o SLINTST = schkaa.o \ schkeq.o schkgb.o schkge.o schkgt.o \ schklq.o schkpb.o schkpo.o schkps.o schkpp.o \ schkpt.o schkq3.o schkql.o schkqr.o schkrq.o \ - schksp.o schksy.o schksy_rook.o schksy_aasen.o schktb.o schktp.o schktr.o \ + schksp.o schksy.o schksy_rook.o schktb.o schktp.o schktr.o \ schktz.o \ sdrvgt.o sdrvls.o sdrvpb.o \ - sdrvpp.o sdrvpt.o sdrvsp.o sdrvsy_rook.o sdrvsy_aasen.o\ + sdrvpp.o sdrvpt.o sdrvsp.o sdrvsy_rook.o\ serrgt.o serrlq.o serrls.o \ serrps.o serrql.o serrqp.o serrqr.o \ serrrq.o serrtr.o serrtz.o \ @@ -70,11 +70,13 @@ SLINTST = schkaa.o \ sqrt01.o sqrt01p.o sqrt02.o sqrt03.o sqrt11.o sqrt12.o \ sqrt13.o sqrt14.o sqrt15.o sqrt16.o sqrt17.o \ srqt01.o srqt02.o srqt03.o srzt01.o srzt02.o \ - sspt01.o ssyt01.o ssyt01_rook.o ssyt01_aasen.o\ + sspt01.o ssyt01.o ssyt01_rook.o \ stbt02.o stbt03.o stbt05.o stbt06.o stpt01.o \ stpt02.o stpt03.o stpt05.o stpt06.o strt01.o \ strt02.o strt03.o strt05.o strt06.o \ - sgennd.o sqrt04.o sqrt05.o schkqrt.o serrqrt.o schkqrtp.o serrqrtp.o + sgennd.o sqrt04.o sqrt05.o schkqrt.o serrqrt.o schkqrtp.o serrqrtp.o \ + schklqt.o schklqtp.o schktsqr.o \ + serrlqt.o serrlqtp.o serrtsqr.o stsqr01.o slqt04.o slqt05.o ifdef USEXBLAS SLINTST += serrvxx.o sdrvgex.o sdrvsyx.o serrgex.o sdrvgbx.o sdrvpox.o \ @@ -86,11 +88,11 @@ endif CLINTST = cchkaa.o \ cchkeq.o cchkgb.o cchkge.o cchkgt.o \ - cchkhe.o cchkhe_rook.o cchkhe_aasen.o cchkhp.o cchklq.o cchkpb.o \ + cchkhe.o cchkhe_rook.o cchkhp.o cchklq.o cchkpb.o \ cchkpo.o cchkps.o cchkpp.o cchkpt.o cchkq3.o cchkql.o \ cchkqr.o cchkrq.o cchksp.o cchksy.o cchksy_rook.o cchktb.o \ cchktp.o cchktr.o cchktz.o \ - cdrvgt.o cdrvhe_rook.o cdrvhe_aasen.o cdrvhp.o \ + cdrvgt.o cdrvhe_rook.o cdrvhp.o \ cdrvls.o cdrvpb.o cdrvpp.o cdrvpt.o \ cdrvsp.o cdrvsy_rook.o \ cerrgt.o cerrlq.o \ @@ -99,7 +101,7 @@ CLINTST = cchkaa.o \ cgbt01.o cgbt02.o cgbt05.o cgelqs.o cgeqls.o cgeqrs.o \ cgerqs.o cget01.o cget02.o \ cget03.o cget04.o cget07.o cgtt01.o cgtt02.o \ - cgtt05.o chet01.o chet01_rook.o chet01_aasen.o chpt01.o claipd.o claptm.o clarhs.o clatb4.o clatb5.o \ + cgtt05.o chet01.o chet01_rook.o chpt01.o claipd.o claptm.o clarhs.o clatb4.o clatb5.o \ clatsp.o clatsy.o clattb.o clattp.o clattr.o \ clavhe.o clavhe_rook.o clavhp.o clavsp.o clavsy.o clavsy_rook.o clqt01.o \ clqt02.o clqt03.o cpbt01.o cpbt02.o cpbt05.o \ @@ -115,7 +117,9 @@ CLINTST = cchkaa.o \ ctpt02.o ctpt03.o ctpt05.o ctpt06.o ctrt01.o \ ctrt02.o ctrt03.o ctrt05.o ctrt06.o \ sget06.o cgennd.o \ - cqrt04.o cqrt05.o cchkqrt.o cerrqrt.o cchkqrtp.o cerrqrtp.o + cqrt04.o cqrt05.o cchkqrt.o cerrqrt.o cchkqrtp.o cerrqrtp.o \ + cchklqt.o cchklqtp.o cchktsqr.o \ + cerrlqt.o cerrlqtp.o cerrtsqr.o ctsqr01.o clqt04.o clqt05.o ifdef USEXBLAS CLINTST += cerrvxx.o cdrvgex.o cdrvsyx.o cdrvgbx.o cerrgex.o cdrvpox.o \ @@ -129,10 +133,10 @@ DLINTST = dchkaa.o \ dchkeq.o dchkgb.o dchkge.o dchkgt.o \ dchklq.o dchkpb.o dchkpo.o dchkps.o dchkpp.o \ dchkpt.o dchkq3.o dchkql.o dchkqr.o dchkrq.o \ - dchksp.o dchksy.o dchksy_rook.o dchksy_aasen.o dchktb.o dchktp.o dchktr.o \ + dchksp.o dchksy.o dchksy_rook.o dchktb.o dchktp.o dchktr.o \ dchktz.o \ ddrvgt.o ddrvls.o ddrvpb.o \ - ddrvpp.o ddrvpt.o ddrvsp.o ddrvsy_rook.o ddrvsy_aasen.o\ + ddrvpp.o ddrvpt.o ddrvsp.o ddrvsy_rook.o \ derrgt.o derrlq.o derrls.o \ derrps.o derrql.o derrqp.o derrqr.o \ derrrq.o derrtr.o derrtz.o \ @@ -148,12 +152,14 @@ DLINTST = dchkaa.o \ dqrt01.o dqrt01p.o dqrt02.o dqrt03.o dqrt11.o dqrt12.o \ dqrt13.o dqrt14.o dqrt15.o dqrt16.o dqrt17.o \ drqt01.o drqt02.o drqt03.o drzt01.o drzt02.o \ - dspt01.o dsyt01.o dsyt01_rook.o dsyt01_aasen.o\ + dspt01.o dsyt01.o dsyt01_rook.o \ dtbt02.o dtbt03.o dtbt05.o dtbt06.o dtpt01.o \ dtpt02.o dtpt03.o dtpt05.o dtpt06.o dtrt01.o \ dtrt02.o dtrt03.o dtrt05.o dtrt06.o \ dgennd.o \ - dqrt04.o dqrt05.o dchkqrt.o derrqrt.o dchkqrtp.o derrqrtp.o + dqrt04.o dqrt05.o dchkqrt.o derrqrt.o dchkqrtp.o derrqrtp.o \ + dchklq.o dchklqt.o dchklqtp.o dchktsqr.o \ + derrlqt.o derrlqtp.o derrtsqr.o dtsqr01.o dlqt04.o dlqt05.o ifdef USEXBLAS DLINTST += derrvxx.o ddrvgex.o ddrvsyx.o ddrvgbx.o derrgex.o ddrvpox.o derrpox.o \ @@ -165,11 +171,11 @@ endif ZLINTST = zchkaa.o \ zchkeq.o zchkgb.o zchkge.o zchkgt.o \ - zchkhe.o zchkhe_rook.o zchkhe_aasen.o zchkhp.o zchklq.o zchkpb.o \ + zchkhe.o zchkhe_rook.o zchkhp.o zchklq.o zchkpb.o \ zchkpo.o zchkps.o zchkpp.o zchkpt.o zchkq3.o zchkql.o \ zchkqr.o zchkrq.o zchksp.o zchksy.o zchksy_rook.o zchktb.o \ zchktp.o zchktr.o zchktz.o \ - zdrvgt.o zdrvhe_rook.o zdrvhe_aasen.o zdrvhp.o \ + zdrvgt.o zdrvhe_rook.o zdrvhp.o \ zdrvls.o zdrvpb.o zdrvpp.o zdrvpt.o \ zdrvsp.o zdrvsy_rook.o \ zerrgt.o zerrlq.o \ @@ -178,7 +184,7 @@ ZLINTST = zchkaa.o \ zgbt01.o zgbt02.o zgbt05.o zgelqs.o zgeqls.o zgeqrs.o \ zgerqs.o zget01.o zget02.o \ zget03.o zget04.o zget07.o zgtt01.o zgtt02.o \ - zgtt05.o zhet01.o zhet01_rook.o zhet01_aasen.o zhpt01.o zlaipd.o zlaptm.o zlarhs.o zlatb4.o zlatb5.o \ + zgtt05.o zhet01.o zhet01_rook.o zhpt01.o zlaipd.o zlaptm.o zlarhs.o zlatb4.o zlatb5.o \ zlatsp.o zlatsy.o zlattb.o zlattp.o zlattr.o \ zlavhe.o zlavhe_rook.o zlavhp.o zlavsp.o zlavsy.o zlavsy_rook.o zlqt01.o \ zlqt02.o zlqt03.o zpbt01.o zpbt02.o zpbt05.o \ @@ -194,7 +200,9 @@ ZLINTST = zchkaa.o \ ztpt02.o ztpt03.o ztpt05.o ztpt06.o ztrt01.o \ ztrt02.o ztrt03.o ztrt05.o ztrt06.o \ dget06.o zgennd.o \ - zqrt04.o zqrt05.o zchkqrt.o zerrqrt.o zchkqrtp.o zerrqrtp.o + zqrt04.o zqrt05.o zchkqrt.o zerrqrt.o zchkqrtp.o zerrqrtp.o \ + zchklqt.o zchklqtp.o zchktsqr.o \ + zerrlqt.o zerrlqtp.o zerrtsqr.o ztsqr01.o zlqt04.o zlqt05.o ifdef USEXBLAS ZLINTST += zerrvxx.o zdrvgex.o zdrvsyx.o zdrvgbx.o zerrgex.o zdrvpox.o zdrvhex.o \ @@ -218,26 +226,26 @@ ZCLINTST = zchkab.o \ SLINTSTRFP = schkrfp.o sdrvrfp.o sdrvrf1.o sdrvrf2.o sdrvrf3.o sdrvrf4.o serrrfp.o \ slatb4.o slarhs.o sget04.o spot01.o spot03.o spot02.o \ - chkxer.o xerbla.o alaerh.o aladhd.o alahd.o alasvm.o + chkxer.o xerbla.o alaerh.o aladhd.o alahd.o alasvm.o DLINTSTRFP = dchkrfp.o ddrvrfp.o ddrvrf1.o ddrvrf2.o ddrvrf3.o ddrvrf4.o derrrfp.o \ dlatb4.o dlarhs.o dget04.o dpot01.o dpot03.o dpot02.o \ - chkxer.o xerbla.o alaerh.o aladhd.o alahd.o alasvm.o + chkxer.o xerbla.o alaerh.o aladhd.o alahd.o alasvm.o CLINTSTRFP = cchkrfp.o cdrvrfp.o cdrvrf1.o cdrvrf2.o cdrvrf3.o cdrvrf4.o cerrrfp.o \ claipd.o clatb4.o clarhs.o csbmv.o cget04.o cpot01.o cpot03.o cpot02.o \ - chkxer.o xerbla.o alaerh.o aladhd.o alahd.o alasvm.o + chkxer.o xerbla.o alaerh.o aladhd.o alahd.o alasvm.o ZLINTSTRFP = zchkrfp.o zdrvrfp.o zdrvrf1.o zdrvrf2.o zdrvrf3.o zdrvrf4.o zerrrfp.o \ zlatb4.o zlaipd.o zlarhs.o zsbmv.o zget04.o zpot01.o zpot03.o zpot02.o \ - chkxer.o xerbla.o alaerh.o aladhd.o alahd.o alasvm.o + chkxer.o xerbla.o alaerh.o aladhd.o alahd.o alasvm.o all: single double complex complex16 proto-single proto-double proto-complex proto-complex16 single: ../xlintsts -double: ../xlintstd +double: ../xlintstd complex: ../xlintstc -complex16: ../xlintstz +complex16: ../xlintstz proto-single: ../xlintstrfs proto-double: ../xlintstds ../xlintstrfd @@ -251,39 +259,39 @@ xlintsts : $(ALINTST) $(SLINTST) $(SCLNTST) ../../$(LAPACKLIB) xlintstc : $(ALINTST) $(CLINTST) $(SCLNTST) ../../$(LAPACKLIB) $(LOADER) $(LOADOPTS) $(ALINTST) $(SCLNTST) $(CLINTST) \ ../../$(TMGLIB) ../../$(LAPACKLIB) $(XBLASLIB) $(BLASLIB) -o $@ - + xlintstd : $(ALINTST) $(DLINTST) $(DZLNTST) ../../$(LAPACKLIB) $(LOADER) $(LOADOPTS) $^ \ ../../$(TMGLIB) ../../$(LAPACKLIB) $(XBLASLIB) $(BLASLIB) -o $@ - + xlintstz : $(ALINTST) $(ZLINTST) $(DZLNTST) ../../$(LAPACKLIB) $(LOADER) $(LOADOPTS) $(ALINTST) $(DZLNTST) $(ZLINTST) \ ../../$(TMGLIB) ../../$(LAPACKLIB) $(XBLASLIB) $(BLASLIB) -o $@ - + xlintstds : $(DSLINTST) ../../$(LAPACKLIB) $(LOADER) $(LOADOPTS) $(DSLINTST) \ ../../$(TMGLIB) ../../$(LAPACKLIB) $(BLASLIB) -o $@ - + xlintstzc : $(ZCLINTST) ../../$(LAPACKLIB) $(LOADER) $(LOADOPTS) $(ZCLINTST) \ ../../$(TMGLIB) ../../$(LAPACKLIB) $(BLASLIB) -o $@ - + xlintstrfs : $(SLINTSTRFP) ../../$(LAPACKLIB) $(LOADER) $(LOADOPTS) $(SLINTSTRFP) \ ../../$(TMGLIB) ../../$(LAPACKLIB) $(BLASLIB) -o $@ - + xlintstrfd : $(DLINTSTRFP) ../../$(LAPACKLIB) $(LOADER) $(LOADOPTS) $(DLINTSTRFP) \ ../../$(TMGLIB) ../../$(LAPACKLIB) $(BLASLIB) -o $@ - + xlintstrfc : $(CLINTSTRFP) ../../$(LAPACKLIB) $(LOADER) $(LOADOPTS) $(CLINTSTRFP) \ ../../$(TMGLIB) ../../$(LAPACKLIB) $(BLASLIB) -o $@ - + xlintstrfz : $(ZLINTSTRFP) ../../$(LAPACKLIB) $(LOADER) $(LOADOPTS) $(ZLINTSTRFP) \ ../../$(TMGLIB) ../../$(LAPACKLIB) $(BLASLIB) -o $@ - + ../xlintsts: xlintsts mv xlintsts $@ @@ -324,7 +332,7 @@ $(ZLINTST): $(FRC) FRC: @FRC=$(FRC) - + clean: rm -f *.o @@ -336,8 +344,8 @@ cchkaa.o: cchkaa.f $(FORTRAN) $(DRVOPTS) -c $< -o $@ zchkaa.o: zchkaa.f $(FORTRAN) $(DRVOPTS) -c $< -o $@ - -.f.o: + +.f.o: $(FORTRAN) $(OPTS) -c $< -o $@ .NOTPARALLEL: diff --git a/TESTING/LIN/alaerh.f b/TESTING/LIN/alaerh.f index 4fec4522..2f58e85c 100644 --- a/TESTING/LIN/alaerh.f +++ b/TESTING/LIN/alaerh.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ALAERH( PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, * N5, IMAT, NFAIL, NERRS, NOUT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * CHARACTER*( * ) SUBNAM @@ -18,7 +18,7 @@ * INTEGER IMAT, INFO, INFOE, KL, KU, M, N, N5, NERRS, * $ NFAIL, NOUT * .. -* +* * *> \par Purpose: * ============= @@ -134,10 +134,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date November 2013 * @@ -490,7 +490,6 @@ ELSE IF( LSAMEN( 2, P2, 'SY' ) $ .OR. LSAMEN( 2, P2, 'SR' ) $ .OR. LSAMEN( 2, P2, 'HE' ) - $ .OR. LSAMEN( 2, P2, 'HA' ) $ .OR. LSAMEN( 2, P2, 'HR' ) ) THEN * * xSY: symmetric indefinite matrices @@ -499,8 +498,6 @@ * with rook (bounded Bunch-Kaufman) pivoting; * xHE: Hermitian indefinite matrices * with partial (Bunch-Kaufman) pivoting. -* xHA: Hermitian matrices -* Aasen Algorithm * xHR: Hermitian indefinite matrices * with rook (bounded Bunch-Kaufman) pivoting; * diff --git a/TESTING/LIN/alahd.f b/TESTING/LIN/alahd.f index 995a5444..e482a26d 100644 --- a/TESTING/LIN/alahd.f +++ b/TESTING/LIN/alahd.f @@ -53,8 +53,6 @@ *> with "rook" (bounded Bunch-Kaufman) pivoting *> _SP: Symmetric indefinite packed, *> with partial (Bunch-Kaufman) pivoting -*> _HA: (complex) Hermitian , -*> with Aasen Algorithm *> _HE: (complex) Hermitian indefinite, *> with partial (Bunch-Kaufman) pivoting *> _HR: Symmetric indefinite, @@ -357,28 +355,6 @@ WRITE( IOUNIT, FMT = 9955 )8 WRITE( IOUNIT, FMT = '( '' Messages:'' )' ) * - ELSE IF( LSAMEN( 2, P2, 'HA' ) ) THEN -* -* HA: Hermitian, -* with Assen Algorithm -* - WRITE( IOUNIT, FMT = 9992 )PATH, 'Hermitian' -* - WRITE( IOUNIT, FMT = '( '' Matrix types:'' )' ) - WRITE( IOUNIT, FMT = 9972 ) -* - WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' ) - WRITE( IOUNIT, FMT = 9953 )1 - WRITE( IOUNIT, FMT = 9961 )2 - WRITE( IOUNIT, FMT = 9960 )3 - WRITE( IOUNIT, FMT = 9960 )4 - WRITE( IOUNIT, FMT = 9959 )5 - WRITE( IOUNIT, FMT = 9958 )6 - WRITE( IOUNIT, FMT = 9956 )7 - WRITE( IOUNIT, FMT = 9957 )8 - WRITE( IOUNIT, FMT = 9955 )9 - WRITE( IOUNIT, FMT = '( '' Messages:'' )' ) -* ELSE IF( LSAMEN( 2, P2, 'HE' ) ) THEN * * HE: Hermitian indefinite full, @@ -591,7 +567,7 @@ * WRITE( IOUNIT, FMT = 9984 )PATH WRITE( IOUNIT, FMT = 9967 ) - WRITE( IOUNIT, FMT = 9921 )C1, C1, C1, C1 + WRITE( IOUNIT, FMT = 9921 )C1, C1, C1, C1, C1 WRITE( IOUNIT, FMT = 9935 )1 WRITE( IOUNIT, FMT = 9931 )2 WRITE( IOUNIT, FMT = 9933 )3 @@ -658,6 +634,45 @@ WRITE( IOUNIT, FMT = 8021 ) 5 WRITE( IOUNIT, FMT = 8022 ) 6 * + ELSE IF( LSAMEN( 2, P2, 'TQ' ) ) THEN +* +* QRT (triangular-pentagonal) +* + WRITE( IOUNIT, FMT = 8002 ) PATH + WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' ) + WRITE( IOUNIT, FMT = 8023 ) 1 + WRITE( IOUNIT, FMT = 8024 ) 2 + WRITE( IOUNIT, FMT = 8025 ) 3 + WRITE( IOUNIT, FMT = 8026 ) 4 + WRITE( IOUNIT, FMT = 8027 ) 5 + WRITE( IOUNIT, FMT = 8028 ) 6 +* + ELSE IF( LSAMEN( 2, P2, 'XQ' ) ) THEN +* +* QRT (triangular-pentagonal) +* + WRITE( IOUNIT, FMT = 8003 ) PATH + WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' ) + WRITE( IOUNIT, FMT = 8029 ) 1 + WRITE( IOUNIT, FMT = 8030 ) 2 + WRITE( IOUNIT, FMT = 8031 ) 3 + WRITE( IOUNIT, FMT = 8032 ) 4 + WRITE( IOUNIT, FMT = 8033 ) 5 + WRITE( IOUNIT, FMT = 8034 ) 6 +* + ELSE IF( LSAMEN( 2, P2, 'TS' ) ) THEN +* +* QRT (triangular-pentagonal) +* + WRITE( IOUNIT, FMT = 8004 ) PATH + WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' ) + WRITE( IOUNIT, FMT = 8035 ) 1 + WRITE( IOUNIT, FMT = 8036 ) 2 + WRITE( IOUNIT, FMT = 8037 ) 3 + WRITE( IOUNIT, FMT = 8038 ) 4 + WRITE( IOUNIT, FMT = 8039 ) 5 + WRITE( IOUNIT, FMT = 8040 ) 6 +* ELSE * * Print error message if no header is available. @@ -698,6 +713,11 @@ 8000 FORMAT( / 1X, A3, ': QRT factorization for general matrices' ) 8001 FORMAT( / 1X, A3, ': QRT factorization for ', $ 'triangular-pentagonal matrices' ) + 8002 FORMAT( / 1X, A3, ': LQT factorization for general matrices' ) + 8003 FORMAT( / 1X, A3, ': LQT factorization for ', + $ 'triangular-pentagonal matrices' ) + 8004 FORMAT( / 1X, A3, ': TS factorization for ', + $ 'tall-skiny or short-wide matrices' ) * * GE matrix types * @@ -970,7 +990,8 @@ 9929 FORMAT( ' Test ratios (1-3: ', A1, 'TZRZF):' ) 9920 FORMAT( 3X, ' 7-10: same as 3-6', 3X, ' 11-14: same as 3-6' ) 9921 FORMAT( ' Test ratios:', / ' (1-2: ', A1, 'GELS, 3-6: ', A1, - $ 'GELSY, 7-10: ', A1, 'GELSS, 11-14: ', A1, 'GELSD)' ) + $ 'GELSY, 7-10: ', A1, 'GELSS, 11-14: ', A1, 'GELSD, 15-16: ' + $ A1, 'GETSLS)') 9928 FORMAT( 7X, 'where ALPHA = ( 1 + SQRT( 17 ) ) / 8' ) 9927 FORMAT( 3X, I2, ': ABS( Largest element in L )', / 12X, $ ' - ( 1 / ( 1 - ALPHA ) ) + THRESH' ) @@ -990,6 +1011,30 @@ 8021 FORMAT(3X,I2,': norm( C*Q - C*Q ) / ( (M+N) * norm(C) * EPS )' ) 8022 FORMAT(3X,I2, $ ': norm( C*Q'' - C*Q'' ) / ( (M+N) * norm(C) * EPS )') + 8023 FORMAT(3X,I2,': norm( L - A*Q'' ) / ( (M+N) * norm(A) * EPS )' ) + 8024 FORMAT(3X,I2,': norm( I - Q*Q'' ) / ( (M+N) * EPS )' ) + 8025 FORMAT(3X,I2,': norm( Q*C - Q*C ) / ( (M+N) * norm(C) * EPS )' ) + 8026 FORMAT(3X,I2, + $ ': norm( Q''*C - Q''*C ) / ( (M+N) * norm(C) * EPS )') + 8027 FORMAT(3X,I2,': norm( C*Q - C*Q ) / ( (M+N) * norm(C) * EPS )' ) + 8028 FORMAT(3X,I2, + $ ': norm( C*Q'' - C*Q'' ) / ( (M+N) * norm(C) * EPS )') + 8029 FORMAT(3X,I2,': norm( L - A*Q'' ) / ( (M+N) * norm(A) * EPS )' ) + 8030 FORMAT(3X,I2,': norm( I - Q*Q'' ) / ( (M+N) * EPS )' ) + 8031 FORMAT(3X,I2,': norm( Q*C - Q*C ) / ( (M+N) * norm(C) * EPS )' ) + 8032 FORMAT(3X,I2, + $ ': norm( Q''*C - Q''*C ) / ( (M+N) * norm(C) * EPS )') + 8033 FORMAT(3X,I2,': norm( C*Q - C*Q ) / ( (M+N) * norm(C) * EPS )' ) + 8034 FORMAT(3X,I2, + $ ': norm( C*Q'' - C*Q'' ) / ( (M+N) * norm(C) * EPS )') + 8035 FORMAT(3X,I2,': norm( R - Q''*A ) / ( (M+N) * norm(A) * EPS )' ) + 8036 FORMAT(3X,I2,': norm( I - Q''*Q ) / ( (M+N) * EPS )' ) + 8037 FORMAT(3X,I2,': norm( Q*C - Q*C ) / ( (M+N) * norm(C) * EPS )' ) + 8038 FORMAT(3X,I2, + $ ': norm( Q''*C - Q''*C ) / ( (M+N) * norm(C) * EPS )') + 8039 FORMAT(3X,I2,': norm( C*Q - C*Q ) / ( (M+N) * norm(C) * EPS )' ) + 8040 FORMAT(3X,I2, + $ ': norm( C*Q'' - C*Q'' ) / ( (M+N) * norm(C) * EPS )') * RETURN * diff --git a/TESTING/LIN/cchkaa.f b/TESTING/LIN/cchkaa.f index 1f8b2c65..ac71efce 100644 --- a/TESTING/LIN/cchkaa.f +++ b/TESTING/LIN/cchkaa.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * PROGRAM CCHKAA -* +* * *> \par Purpose: * ============= @@ -51,7 +51,6 @@ *> CPT 12 List types on next line if 0 < NTYPES < 12 *> CHE 10 List types on next line if 0 < NTYPES < 10 *> CHR 10 List types on next line if 0 < NTYPES < 10 -*> CHA 10 List types on next line if 0 < NTYPES < 10 *> CHP 10 List types on next line if 0 < NTYPES < 10 *> CSY 11 List types on next line if 0 < NTYPES < 11 *> CSR 11 List types on next line if 0 < NTYPES < 11 @@ -98,22 +97,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2016 +*> \date November 2015 * *> \ingroup complex_lin * * ===================================================================== PROGRAM CCHKAA * -* -- LAPACK test routine (version 3.7.0) -- +* -- LAPACK test routine (version 3.6.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2016 +* November 2015 * * ===================================================================== * @@ -642,33 +641,6 @@ WRITE( NOUT, FMT = 9988 )PATH END IF * - ELSE IF( LSAMEN( 2, C2, 'HA' ) ) THEN -* -* HA: Hermitian matrices, -* Aasen Algorithm -* - NTYPES = 10 - CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) -* - IF( TSTCHK ) THEN - CALL CCHKHE_AASEN( DOTYPE, NN, NVAL, NNB2, NBVAL2, NNS, - $ NSVAL, THRESH, TSTERR, LDA, - $ A( 1, 1 ), A( 1, 2 ), A( 1, 3 ), - $ B( 1, 1 ), B( 1, 2 ), B( 1, 3 ), - $ WORK, RWORK, IWORK, NOUT ) - ELSE - WRITE( NOUT, FMT = 9989 )PATH - END IF -* - IF( TSTDRV ) THEN - CALL CDRVHE_AASEN( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, - $ LDA, A( 1, 1 ), A( 1, 2 ), A( 1, 3 ), - $ B( 1, 1 ), B( 1, 2 ), B( 1, 3 ), - $ WORK, RWORK, IWORK, NOUT ) - ELSE - WRITE( NOUT, FMT = 9988 )PATH - END IF -* ELSE IF( LSAMEN( 2, C2, 'HR' ) ) THEN * * HR: Hermitian indefinite matrices, @@ -895,6 +867,7 @@ ELSE WRITE( NOUT, FMT = 9989 )PATH END IF + * ELSE IF( LSAMEN( 2, C2, 'RQ' ) ) THEN * @@ -953,6 +926,7 @@ ELSE WRITE( NOUT, FMT = 9989 )PATH END IF + * ELSE IF( LSAMEN( 2, C2, 'LS' ) ) THEN * @@ -976,7 +950,7 @@ * QT: QRT routines for general matrices * IF( TSTCHK ) THEN - CALL CCHKQRT( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, + CALL CCHKQRT( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, $ NBVAL, NOUT ) ELSE WRITE( NOUT, FMT = 9989 )PATH @@ -987,7 +961,40 @@ * QX: QRT routines for triangular-pentagonal matrices * IF( TSTCHK ) THEN - CALL CCHKQRTP( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, + CALL CCHKQRTP( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, + $ NBVAL, NOUT ) + ELSE + WRITE( NOUT, FMT = 9989 )PATH + END IF +* + ELSE IF( LSAMEN( 2, C2, 'TQ' ) ) THEN +* +* TQ: LQT routines for general matrices +* + IF( TSTCHK ) THEN + CALL CCHKLQT( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, + $ NBVAL, NOUT ) + ELSE + WRITE( NOUT, FMT = 9989 )PATH + END IF +* + ELSE IF( LSAMEN( 2, C2, 'XQ' ) ) THEN +* +* XQ: LQT routines for triangular-pentagonal matrices +* + IF( TSTCHK ) THEN + CALL CCHKLQTP( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, + $ NBVAL, NOUT ) + ELSE + WRITE( NOUT, FMT = 9989 )PATH + END IF +* + ELSE IF( LSAMEN( 2, C2, 'TS' ) ) THEN +* +* TS: QR routines for tall-skinny matrices +* + IF( TSTCHK ) THEN + CALL CCHKTSQR( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, $ NBVAL, NOUT ) ELSE WRITE( NOUT, FMT = 9989 )PATH diff --git a/TESTING/LIN/cchklqt.f b/TESTING/LIN/cchklqt.f new file mode 100644 index 00000000..d6c4f7e1 --- /dev/null +++ b/TESTING/LIN/cchklqt.f @@ -0,0 +1,210 @@ +*> \brief \b CCHKLQT +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CCHKLQT( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, +* NBVAL, NOUT ) +* +* .. Scalar Arguments .. +* LOGICAL TSTERR +* INTEGER NM, NN, NNB, NOUT +* REAL THRESH +* .. +* .. Array Arguments .. +* INTEGER MVAL( * ), NBVAL( * ), NVAL( * ) +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CCHKLQT tests CGELQT and CUNMLQT. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] THRESH +*> \verbatim +*> THRESH is REAL +*> The threshold value for the test ratios. A result is +*> included in the output file if RESULT >= THRESH. To have +*> every test ratio printed, use THRESH = 0. +*> \endverbatim +*> +*> \param[in] TSTERR +*> \verbatim +*> TSTERR is LOGICAL +*> Flag that indicates whether error exits are to be tested. +*> \endverbatim +*> +*> \param[in] NM +*> \verbatim +*> NM is INTEGER +*> The number of values of M contained in the vector MVAL. +*> \endverbatim +*> +*> \param[in] MVAL +*> \verbatim +*> MVAL is INTEGER array, dimension (NM) +*> The values of the matrix row dimension M. +*> \endverbatim +*> +*> \param[in] NN +*> \verbatim +*> NN is INTEGER +*> The number of values of N contained in the vector NVAL. +*> \endverbatim +*> +*> \param[in] NVAL +*> \verbatim +*> NVAL is INTEGER array, dimension (NN) +*> The values of the matrix column dimension N. +*> \endverbatim +*> +*> \param[in] NNB +*> \verbatim +*> NNB is INTEGER +*> The number of values of NB contained in the vector NBVAL. +*> \endverbatim +*> +*> \param[in] NBVAL +*> \verbatim +*> NBVAL is INTEGER array, dimension (NBVAL) +*> The values of the blocksize NB. +*> \endverbatim +*> +*> \param[in] NOUT +*> \verbatim +*> NOUT is INTEGER +*> The unit number for output. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2011 +* +*> \ingroup double_lin +* +* ===================================================================== + SUBROUTINE CCHKLQT( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, + $ NBVAL, NOUT ) + IMPLICIT NONE +* +* -- LAPACK test routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + LOGICAL TSTERR + INTEGER NM, NN, NNB, NOUT + REAL THRESH +* .. +* .. Array Arguments .. + INTEGER MVAL( * ), NBVAL( * ), NVAL( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER NTESTS + PARAMETER ( NTESTS = 6 ) +* .. +* .. Local Scalars .. + CHARACTER*3 PATH + INTEGER I, J, K, T, M, N, NB, NFAIL, NERRS, NRUN, + $ MINMN +* +* .. Local Arrays .. + REAL RESULT( NTESTS ) +* .. +* .. External Subroutines .. + EXTERNAL ALAERH, ALAHD, ALASUM, CERRLQT, CLQT04 +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, NUNIT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NUNIT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Executable Statements .. +* +* Initialize constants +* + PATH( 1: 1 ) = 'C' + PATH( 2: 3 ) = 'TQ' + NRUN = 0 + NFAIL = 0 + NERRS = 0 +* +* Test the error exits +* + IF( TSTERR ) CALL CERRLQT( PATH, NOUT ) + INFOT = 0 +* +* Do for each value of M in MVAL. +* + DO I = 1, NM + M = MVAL( I ) +* +* Do for each value of N in NVAL. +* + DO J = 1, NN + N = NVAL( J ) +* +* Do for each possible value of NB +* + MINMN = MIN( M, N ) + DO K = 1, NNB + NB = NBVAL( K ) +* +* Test CGELQT and CUNMLQT +* + IF( (NB.LE.MINMN).AND.(NB.GT.0) ) THEN + CALL CLQT04( M, N, NB, RESULT ) +* +* Print information about the tests that did not +* pass the threshold. +* + DO T = 1, NTESTS + IF( RESULT( T ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 )M, N, NB, + $ T, RESULT( T ) + NFAIL = NFAIL + 1 + END IF + END DO + NRUN = NRUN + NTESTS + END IF + END DO + END DO + END DO +* +* Print a summary of the results. +* + CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) +* + 9999 FORMAT( ' M=', I5, ', N=', I5, ', NB=', I4, + $ ' test(', I2, ')=', G12.5 ) + RETURN +* +* End of CCHKLQT +* + END diff --git a/TESTING/LIN/cchklqtp.f b/TESTING/LIN/cchklqtp.f new file mode 100644 index 00000000..5e573e4c --- /dev/null +++ b/TESTING/LIN/cchklqtp.f @@ -0,0 +1,215 @@ +*> \brief \b CCHKLQTP +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CCHKLQTP( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, +* NBVAL, NOUT ) +* +* .. Scalar Arguments .. +* LOGICAL TSTERR +* INTEGER NM, NN, NNB, NOUT +* REAL THRESH +* .. +* .. Array Arguments .. +* INTEGER MVAL( * ), NBVAL( * ), NVAL( * ) +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CCHKLQTP tests CTPLQT and CTPMLQT. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] THRESH +*> \verbatim +*> THRESH is REAL +*> The threshold value for the test ratios. A result is +*> included in the output file if RESULT >= THRESH. To have +*> every test ratio printed, use THRESH = 0. +*> \endverbatim +*> +*> \param[in] TSTERR +*> \verbatim +*> TSTERR is LOGICAL +*> Flag that indicates whether error exits are to be tested. +*> \endverbatim +*> +*> \param[in] NM +*> \verbatim +*> NM is INTEGER +*> The number of values of M contained in the vector MVAL. +*> \endverbatim +*> +*> \param[in] MVAL +*> \verbatim +*> MVAL is INTEGER array, dimension (NM) +*> The values of the matrix row dimension M. +*> \endverbatim +*> +*> \param[in] NN +*> \verbatim +*> NN is INTEGER +*> The number of values of N contained in the vector NVAL. +*> \endverbatim +*> +*> \param[in] NVAL +*> \verbatim +*> NVAL is INTEGER array, dimension (NN) +*> The values of the matrix column dimension N. +*> \endverbatim +*> +*> \param[in] NNB +*> \verbatim +*> NNB is INTEGER +*> The number of values of NB contained in the vector NBVAL. +*> \endverbatim +*> +*> \param[in] NBVAL +*> \verbatim +*> NBVAL is INTEGER array, dimension (NBVAL) +*> The values of the blocksize NB. +*> \endverbatim +*> +*> \param[in] NOUT +*> \verbatim +*> NOUT is INTEGER +*> The unit number for output. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2011 +* +*> \ingroup double_lin +* +* ===================================================================== + SUBROUTINE CCHKLQTP( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, + $ NBVAL, NOUT ) + IMPLICIT NONE +* +* -- LAPACK test routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + LOGICAL TSTERR + INTEGER NM, NN, NNB, NOUT + REAL THRESH +* .. +* .. Array Arguments .. + INTEGER MVAL( * ), NBVAL( * ), NVAL( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER NTESTS + PARAMETER ( NTESTS = 6 ) +* .. +* .. Local Scalars .. + CHARACTER*3 PATH + INTEGER I, J, K, L, T, M, N, NB, NFAIL, NERRS, NRUN, + $ MINMN +* .. +* .. Local Arrays .. + REAL RESULT( NTESTS ) +* .. +* .. External Subroutines .. + EXTERNAL ALAERH, ALAHD, ALASUM, CERRLQTP, CLQT04 +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, NUNIT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NUNIT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Executable Statements .. +* +* Initialize constants +* + PATH( 1: 1 ) = 'C' + PATH( 2: 3 ) = 'XQ' + NRUN = 0 + NFAIL = 0 + NERRS = 0 +* +* Test the error exits +* + IF( TSTERR ) CALL CERRLQTP( PATH, NOUT ) + INFOT = 0 +* +* Do for each value of M +* + DO I = 1, NM + M = MVAL( I ) +* +* Do for each value of N +* + DO J = 1, NN + N = NVAL( J ) +* +* Do for each value of L +* + MINMN = MIN( M, N ) + DO L = 0, MINMN, MAX( MINMN, 1 ) +* +* Do for each possible value of NB +* + DO K = 1, NNB + NB = NBVAL( K ) +* +* Test DTPLQT and DTPMLQT +* + IF( (NB.LE.M).AND.(NB.GT.0) ) THEN + CALL CLQT05( M, N, L, NB, RESULT ) +* +* Print information about the tests that did not +* pass the threshold. +* + DO T = 1, NTESTS + IF( RESULT( T ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 )M, N, NB, L, + $ T, RESULT( T ) + NFAIL = NFAIL + 1 + END IF + END DO + NRUN = NRUN + NTESTS + END IF + END DO + END DO + END DO + END DO +* +* Print a summary of the results. +* + CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) +* + 9999 FORMAT( ' M=', I5, ', N=', I5, ', NB=', I4,' L=', I4, + $ ' test(', I2, ')=', G12.5 ) + RETURN +* +* End of CCHKLQTP +* + END
\ No newline at end of file diff --git a/TESTING/LIN/cchktsqr.f b/TESTING/LIN/cchktsqr.f new file mode 100644 index 00000000..8c55f399 --- /dev/null +++ b/TESTING/LIN/cchktsqr.f @@ -0,0 +1,257 @@ +*> \brief \b CCHKQRT +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CCHKTSQR( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, +* NBVAL, NOUT ) +* +* .. Scalar Arguments .. +* LOGICAL TSTERR +* INTEGER NM, NN, NNB, NOUT +* REAL THRESH +* .. +* .. Array Arguments .. +* INTEGER MVAL( * ), NBVAL( * ), NVAL( * ) +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CCHKTSQR tests CGEQR and CGEMQR. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] THRESH +*> \verbatim +*> THRESH is REAL +*> The threshold value for the test ratios. A result is +*> included in the output file if RESULT >= THRESH. To have +*> every test ratio printed, use THRESH = 0. +*> \endverbatim +*> +*> \param[in] TSTERR +*> \verbatim +*> TSTERR is LOGICAL +*> Flag that indicates whether error exits are to be tested. +*> \endverbatim +*> +*> \param[in] NM +*> \verbatim +*> NM is INTEGER +*> The number of values of M contained in the vector MVAL. +*> \endverbatim +*> +*> \param[in] MVAL +*> \verbatim +*> MVAL is INTEGER array, dimension (NM) +*> The values of the matrix row dimension M. +*> \endverbatim +*> +*> \param[in] NN +*> \verbatim +*> NN is INTEGER +*> The number of values of N contained in the vector NVAL. +*> \endverbatim +*> +*> \param[in] NVAL +*> \verbatim +*> NVAL is INTEGER array, dimension (NN) +*> The values of the matrix column dimension N. +*> \endverbatim +*> +*> \param[in] NNB +*> \verbatim +*> NNB is INTEGER +*> The number of values of NB contained in the vector NBVAL. +*> \endverbatim +*> +*> \param[in] NBVAL +*> \verbatim +*> NBVAL is INTEGER array, dimension (NBVAL) +*> The values of the blocksize NB. +*> \endverbatim +*> +*> \param[in] NOUT +*> \verbatim +*> NOUT is INTEGER +*> The unit number for output. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2011 +* +*> \ingroup double_lin +* +* ===================================================================== + SUBROUTINE CCHKTSQR( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, + $ NBVAL, NOUT ) + IMPLICIT NONE +* +* -- LAPACK test routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + LOGICAL TSTERR + INTEGER NM, NN, NNB, NOUT + REAL THRESH +* .. +* .. Array Arguments .. + INTEGER MVAL( * ), NBVAL( * ), NVAL( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER NTESTS + PARAMETER ( NTESTS = 6 ) +* .. +* .. Local Scalars .. + CHARACTER*3 PATH + INTEGER I, J, K, T, M, N, NB, NFAIL, NERRS, NRUN, INB, + $ MINMN, MB, IMB +* +* .. Local Arrays .. + REAL RESULT( NTESTS ) +* .. +* .. External Subroutines .. + EXTERNAL ALAERH, ALAHD, ALASUM, CERRTSQR, + $ CTSQR01, XLAENV +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, NUNIT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NUNIT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Executable Statements .. +* +* Initialize constants +* + PATH( 1: 1 ) = 'C' + PATH( 2: 3 ) = 'TS' + NRUN = 0 + NFAIL = 0 + NERRS = 0 +* +* Test the error exits +* + IF( TSTERR ) CALL CERRTSQR( PATH, NOUT ) + INFOT = 0 +* +* Do for each value of M in MVAL. +* + DO I = 1, NM + M = MVAL( I ) +* +* Do for each value of N in NVAL. +* + DO J = 1, NN + N = NVAL( J ) + IF (MIN(M,N).NE.0) THEN + DO INB = 1, NNB + MB = NBVAL( INB ) + CALL XLAENV( 1, MB ) + DO IMB = 1, NNB + NB = NBVAL( IMB ) + CALL XLAENV( 2, NB ) +* +* Test DGEQR and DGEMQR +* + CALL CTSQR01( 'TS', M, N, MB, NB, RESULT ) +* +* Print information about the tests that did not +* pass the threshold. +* + DO T = 1, NTESTS + IF( RESULT( T ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 )M, N, MB, NB, + $ T, RESULT( T ) + NFAIL = NFAIL + 1 + END IF + END DO + NRUN = NRUN + NTESTS + END DO + END DO + END IF + END DO + END DO +* +* Do for each value of M in MVAL. +* + DO I = 1, NM + M = MVAL( I ) +* +* Do for each value of N in NVAL. +* + DO J = 1, NN + N = NVAL( J ) + IF (MIN(M,N).NE.0) THEN + DO INB = 1, NNB + MB = NBVAL( INB ) + CALL XLAENV( 1, MB ) + DO IMB = 1, NNB + NB = NBVAL( IMB ) + CALL XLAENV( 2, NB ) +* +* Test DGEQR and DGEMQR +* + CALL CTSQR01( 'SW', M, N, MB, NB, RESULT ) +* +* Print information about the tests that did not +* pass the threshold. +* + DO T = 1, NTESTS + IF( RESULT( T ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9998 )M, N, MB, NB, + $ T, RESULT( T ) + NFAIL = NFAIL + 1 + END IF + END DO + NRUN = NRUN + NTESTS + END DO + END DO + END IF + END DO + END DO +* +* Print a summary of the results. +* + CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) +* + 9999 FORMAT( 'TS: M=', I5, ', N=', I5, ', MB=', I5, + $ ', NB=', I5,' test(', I2, ')=', G12.5 ) + 9998 FORMAT( 'SW: M=', I5, ', N=', I5, ', MB=', I5, + $ ', NB=', I5,' test(', I2, ')=', G12.5 ) + RETURN +* +* End of CCHKQRT +* + END diff --git a/TESTING/LIN/cdrvls.f b/TESTING/LIN/cdrvls.f index 623d94e3..2e354a61 100644 --- a/TESTING/LIN/cdrvls.f +++ b/TESTING/LIN/cdrvls.f @@ -2,31 +2,30 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CDRVLS( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, NNB, * NBVAL, NXVAL, THRESH, TSTERR, A, COPYA, B, -* COPYB, C, S, COPYS, WORK, RWORK, IWORK, -* NOUT ) -* +* COPYB, C, S, COPYS, WORK, RWORK, IWORK, NOUT ) +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NM, NN, NNB, NNS, NOUT -* REAL THRESH +* REAL THRESH * .. * .. Array Arguments .. * LOGICAL DOTYPE( * ) * INTEGER IWORK( * ), MVAL( * ), NBVAL( * ), NSVAL( * ), * $ NVAL( * ), NXVAL( * ) -* REAL COPYS( * ), RWORK( * ), S( * ) -* COMPLEX A( * ), B( * ), C( * ), COPYA( * ), COPYB( * ), +* REAL COPYS( * ), RWORK( * ), S( * ) +* COMPLEX A( * ), B( * ), C( * ), COPYA( * ), COPYB( * ), * $ WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -196,20 +195,19 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date November 2015 * -*> \ingroup complex_lin +*> \ingroup complex16_lin * * ===================================================================== SUBROUTINE CDRVLS( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, NNB, $ NBVAL, NXVAL, THRESH, TSTERR, A, COPYA, B, - $ COPYB, C, S, COPYS, WORK, RWORK, IWORK, - $ NOUT ) + $ COPYB, C, S, COPYS, WORK, RWORK, IWORK, NOUT ) * * -- LAPACK test routine (version 3.6.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -234,7 +232,7 @@ * * .. Parameters .. INTEGER NTESTS - PARAMETER ( NTESTS = 14 ) + PARAMETER ( NTESTS = 16 ) INTEGER SMLSIZ PARAMETER ( SMLSIZ = 25 ) REAL ONE, ZERO @@ -249,7 +247,7 @@ INTEGER CRANK, I, IM, IN, INB, INFO, INS, IRANK, $ ISCALE, ITRAN, ITYPE, J, K, LDA, LDB, LDWORK, $ LWLSY, LWORK, M, MNMIN, N, NB, NCOLS, NERRS, - $ NFAIL, NRHS, NROWS, NRUN, RANK + $ NFAIL, NRHS, NROWS, NRUN, RANK, MB, LWTS REAL EPS, NORMA, NORMB, RCOND * .. * .. Local Arrays .. @@ -257,17 +255,17 @@ REAL RESULT( NTESTS ) * .. * .. External Functions .. - REAL CQRT12, CQRT14, CQRT17, SASUM, SLAMCH - EXTERNAL CQRT12, CQRT14, CQRT17, SASUM, SLAMCH + REAL SASUM, SLAMCH, CQRT12, CQRT14, CQRT17 + EXTERNAL SASUM, SLAMCH, CQRT12, CQRT14, CQRT17 * .. * .. External Subroutines .. - EXTERNAL ALAERH, ALAHD, ALASVM, CERRLS, CGELS, CGELSD, - $ CGELSS, CGELSY, CGEMM, CLACPY, CLARNV, - $ CQRT13, CQRT15, CQRT16, CSSCAL, SAXPY, - $ XLAENV + EXTERNAL ALAERH, ALAHD, ALASVM, SAXPY, SLASRT, XLAENV, + $ CSSCAL, CERRLS, CGELS, CGELSD, CGELSS, + $ CGELSY, CGEMM, CLACPY, CLARNV, CQRT13, CQRT15, + $ CQRT16, CGETSLS * .. * .. Intrinsic Functions .. - INTRINSIC MAX, MIN, REAL, SQRT + INTRINSIC REAL, MAX, MIN, SQRT * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -317,13 +315,19 @@ * DO 130 IN = 1, NN N = NVAL( IN ) - MNMIN = MIN( M, N ) + MNMIN = MAX(MIN( M, N ),1) LDB = MAX( 1, M, N ) + MB = (MNMIN+1) + IF(MINMN.NE.MB) THEN + LWTS = (((LDB-MB)/(MB-MNMIN))*MNMIN+MNMIN*2)*MB+5 + ELSE + LWTS = 2*MINMN+5 + END IF * DO 120 INS = 1, NNS NRHS = NSVAL( INS ) LWORK = MAX( 1, ( M+NRHS )*( N+2 ), ( N+NRHS )*( M+2 ), - $ M*N+4*MNMIN+MAX( M, N ), 2*N+M ) + $ M*N+4*MNMIN+MAX( M, N ), 2*N+M, LWTS ) * DO 110 IRANK = 1, 2 DO 100 ISCALE = 1, 3 @@ -433,6 +437,110 @@ NRUN = NRUN + 2 30 CONTINUE 40 CONTINUE +* +* +* Test CGETSLS +* +* Generate a matrix of scaling type ISCALE +* + CALL CQRT13( ISCALE, M, N, COPYA, LDA, NORMA, + $ ISEED ) + DO 65 INB = 1, NNB + MB = NBVAL( INB ) + CALL XLAENV( 1, MB ) + DO 62 IMB = 1, NNB + NB = NBVAL( IMB ) + CALL XLAENV( 2, NB ) +* + DO 60 ITRAN = 1, 2 + IF( ITRAN.EQ.1 ) THEN + TRANS = 'N' + NROWS = M + NCOLS = N + ELSE + TRANS = 'C' + NROWS = N + NCOLS = M + END IF + LDWORK = MAX( 1, NCOLS ) +* +* Set up a consistent rhs +* + IF( NCOLS.GT.0 ) THEN + CALL CLARNV( 2, ISEED, NCOLS*NRHS, + $ WORK ) + CALL CSCAL( NCOLS*NRHS, + $ ONE / REAL( NCOLS ), WORK, + $ 1 ) + END IF + CALL CGEMM( TRANS, 'No transpose', NROWS, + $ NRHS, NCOLS, CONE, COPYA, LDA, + $ WORK, LDWORK, CZERO, B, LDB ) + CALL CLACPY( 'Full', NROWS, NRHS, B, LDB, + $ COPYB, LDB ) +* +* Solve LS or overdetermined system +* + IF( M.GT.0 .AND. N.GT.0 ) THEN + CALL CLACPY( 'Full', M, N, COPYA, LDA, + $ A, LDA ) + CALL CLACPY( 'Full', NROWS, NRHS, + $ COPYB, LDB, B, LDB ) + END IF + SRNAMT = 'DGETSLS ' + CALL CGETSLS( TRANS, M, N, NRHS, A, + $ LDA, B, LDB, WORK, LWORK, INFO ) + IF( INFO.NE.0 ) + $ CALL ALAERH( PATH, 'CGETSLS ', INFO, 0, + $ TRANS, M, N, NRHS, -1, NB, + $ ITYPE, NFAIL, NERRS, + $ NOUT ) +* +* Check correctness of results +* + LDWORK = MAX( 1, NROWS ) + IF( NROWS.GT.0 .AND. NRHS.GT.0 ) + $ CALL CLACPY( 'Full', NROWS, NRHS, + $ COPYB, LDB, C, LDB ) + CALL CQRT16( TRANS, M, N, NRHS, COPYA, + $ LDA, B, LDB, C, LDB, WORK, + $ RESULT( 15 ) ) +* + IF( ( ITRAN.EQ.1 .AND. M.GE.N ) .OR. + $ ( ITRAN.EQ.2 .AND. M.LT.N ) ) THEN +* +* Solving LS system +* + RESULT( 16 ) = CQRT17( TRANS, 1, M, N, + $ NRHS, COPYA, LDA, B, LDB, + $ COPYB, LDB, C, WORK, + $ LWORK ) + ELSE +* +* Solving overdetermined system +* + RESULT( 16 ) = CQRT14( TRANS, M, N, + $ NRHS, COPYA, LDA, B, LDB, + $ WORK, LWORK ) + END IF +* +* Print information about the tests that +* did not pass the threshold. +* + DO 50 K = 15, 16 + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9997 )TRANS, M, + $ N, NRHS, MB, NB, ITYPE, K, + $ RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 50 CONTINUE + NRUN = NRUN + 2 + 60 CONTINUE + 62 CONTINUE + 65 CONTINUE END IF * * Generate a matrix of scaling type ISCALE and rank @@ -548,8 +656,8 @@ IF( RANK.GT.0 ) THEN CALL SAXPY( MNMIN, -ONE, COPYS, 1, S, 1 ) RESULT( 7 ) = SASUM( MNMIN, S, 1 ) / - $ SASUM( MNMIN, COPYS, 1 ) / - $ ( EPS*REAL( MNMIN ) ) + $ SASUM( MNMIN, COPYS, 1 ) / + $ ( EPS*REAL( MNMIN ) ) ELSE RESULT( 7 ) = ZERO END IF @@ -567,8 +675,8 @@ RESULT( 9 ) = ZERO IF( M.GT.CRANK ) $ RESULT( 9 ) = CQRT17( 'No transpose', 1, M, - $ N, NRHS, COPYA, LDA, B, LDB, - $ COPYB, LDB, C, WORK, LWORK ) + $ N, NRHS, COPYA, LDA, B, LDB, + $ COPYB, LDB, C, WORK, LWORK ) * * Test 10: Check if x is in the rowspace of A * @@ -637,7 +745,7 @@ * Print information about the tests that did not * pass the threshold. * - DO 80 K = 3, NTESTS + DO 80 K = 3, 14 IF( RESULT( K ).GE.THRESH ) THEN IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) $ CALL ALAHD( NOUT, PATH ) @@ -663,6 +771,9 @@ $ ', NB=', I4, ', type', I2, ', test(', I2, ')=', G12.5 ) 9998 FORMAT( ' M=', I5, ', N=', I5, ', NRHS=', I4, ', NB=', I4, $ ', type', I2, ', test(', I2, ')=', G12.5 ) + 9997 FORMAT( ' TRANS=''', A1,' M=', I5, ', N=', I5, ', NRHS=', I4, + $ ', MB=', I4,', NB=', I4,', type', I2, + $ ', test(', I2, ')=', G12.5 ) RETURN * * End of CDRVLS diff --git a/TESTING/LIN/cerrlqt.f b/TESTING/LIN/cerrlqt.f new file mode 100644 index 00000000..008cb0a9 --- /dev/null +++ b/TESTING/LIN/cerrlqt.f @@ -0,0 +1,197 @@ +*> \brief \b CERRLQT +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CERRLQT( PATH, NUNIT ) +* +* .. Scalar Arguments .. +* CHARACTER*3 PATH +* INTEGER NUNIT +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CERRLQT tests the error exits for the COMPLEX routines +*> that use the LQT decomposition of a general matrix. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] PATH +*> \verbatim +*> PATH is CHARACTER*3 +*> The LAPACK path name for the routines to be tested. +*> \endverbatim +*> +*> \param[in] NUNIT +*> \verbatim +*> NUNIT is INTEGER +*> The unit number for output. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2011 +* +*> \ingroup double_lin +* +* ===================================================================== + SUBROUTINE CERRLQT( PATH, NUNIT ) + IMPLICIT NONE +* +* -- LAPACK test routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + CHARACTER*3 PATH + INTEGER NUNIT +* .. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER NMAX + PARAMETER ( NMAX = 2 ) +* .. +* .. Local Scalars .. + INTEGER I, INFO, J +* .. +* .. Local Arrays .. + COMPLEX A( NMAX, NMAX ), T( NMAX, NMAX ), W( NMAX ), + $ C( NMAX, NMAX ) +* .. +* .. External Subroutines .. + EXTERNAL ALAESM, CHKXER, CGELQT3, CGELQT, + $ CGEMLQT +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, NOUT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NOUT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Intrinsic Functions .. + INTRINSIC REAL, CMPLX +* .. +* .. Executable Statements .. +* + NOUT = NUNIT + WRITE( NOUT, FMT = * ) +* +* Set the variables to innocuous values. +* + DO J = 1, NMAX + DO I = 1, NMAX + A( I, J ) = 1.E0 / CMPLX( REAL( I+J ), 0.E0 ) + C( I, J ) = 1.E0 / CMPLX( REAL( I+J ), 0.E0 ) + T( I, J ) = 1.E0 / CMPLX( REAL( I+J ), 0.E0 ) + END DO + W( J ) = 0.E0 + END DO + OK = .TRUE. +* +* Error exits for LQT factorization +* +* CGELQT +* + SRNAMT = 'CGELQT' + INFOT = 1 + CALL CGELQT( -1, 0, 1, A, 1, T, 1, W, INFO ) + CALL CHKXER( 'CGELQT', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CGELQT( 0, -1, 1, A, 1, T, 1, W, INFO ) + CALL CHKXER( 'CGELQT', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CGELQT( 0, 0, 0, A, 1, T, 1, W, INFO ) + CALL CHKXER( 'CGELQT', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL CGELQT( 2, 1, 1, A, 1, T, 1, W, INFO ) + CALL CHKXER( 'CGELQT', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL CGELQT( 2, 2, 2, A, 2, T, 1, W, INFO ) + CALL CHKXER( 'CGELQT', INFOT, NOUT, LERR, OK ) +* +* CGELQT3 +* + SRNAMT = 'CGELQT3' + INFOT = 1 + CALL CGELQT3( -1, 0, A, 1, T, 1, INFO ) + CALL CHKXER( 'CGELQT3', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CGELQT3( 0, -1, A, 1, T, 1, INFO ) + CALL CHKXER( 'CGELQT3', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CGELQT3( 2, 2, A, 1, T, 1, INFO ) + CALL CHKXER( 'CGELQT3', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL CGELQT3( 2, 2, A, 2, T, 1, INFO ) + CALL CHKXER( 'CGELQT3', INFOT, NOUT, LERR, OK ) +* +* CGEMLQT +* + SRNAMT = 'CGEMLQT' + INFOT = 1 + CALL CGEMLQT( '/', 'N', 0, 0, 0, 1, A, 1, T, 1, C, 1, W, INFO ) + CALL CHKXER( 'CGEMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CGEMLQT( 'L', '/', 0, 0, 0, 1, A, 1, T, 1, C, 1, W, INFO ) + CALL CHKXER( 'CGEMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CGEMLQT( 'L', 'N', -1, 0, 0, 1, A, 1, T, 1, C, 1, W, INFO ) + CALL CHKXER( 'CGEMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CGEMLQT( 'L', 'N', 0, -1, 0, 1, A, 1, T, 1, C, 1, W, INFO ) + CALL CHKXER( 'CGEMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL CGEMLQT( 'L', 'N', 0, 0, -1, 1, A, 1, T, 1, C, 1, W, INFO ) + CALL CHKXER( 'CGEMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL CGEMLQT( 'R', 'N', 0, 0, -1, 1, A, 1, T, 1, C, 1, W, INFO ) + CALL CHKXER( 'CGEMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL CGEMLQT( 'L', 'N', 0, 0, 0, 0, A, 1, T, 1, C, 1, W, INFO ) + CALL CHKXER( 'CGEMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL CGEMLQT( 'R', 'N', 2, 2, 2, 1, A, 1, T, 1, C, 1, W, INFO ) + CALL CHKXER( 'CGEMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL CGEMLQT( 'L', 'N', 2, 2, 2, 1, A, 1, T, 1, C, 1, W, INFO ) + CALL CHKXER( 'CGEMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL CGEMLQT( 'R', 'N', 1, 1, 1, 1, A, 1, T, 0, C, 1, W, INFO ) + CALL CHKXER( 'CGEMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 12 + CALL CGEMLQT( 'L', 'N', 1, 1, 1, 1, A, 1, T, 1, C, 0, W, INFO ) + CALL CHKXER( 'CGEMLQT', INFOT, NOUT, LERR, OK ) +* +* Print a summary line. +* + CALL ALAESM( PATH, OK, NOUT ) +* + RETURN +* +* End of CERRLQT +* + END diff --git a/TESTING/LIN/cerrlqtp.f b/TESTING/LIN/cerrlqtp.f new file mode 100644 index 00000000..45797ddb --- /dev/null +++ b/TESTING/LIN/cerrlqtp.f @@ -0,0 +1,225 @@ +*> \brief \b ZERRLQTP +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CERRLQTP( PATH, NUNIT ) +* +* .. Scalar Arguments .. +* CHARACTER*3 PATH +* INTEGER NUNIT +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CERRLQTP tests the error exits for the complex routines +*> that use the LQT decomposition of a triangular-pentagonal matrix. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] PATH +*> \verbatim +*> PATH is CHARACTER*3 +*> The LAPACK path name for the routines to be tested. +*> \endverbatim +*> +*> \param[in] NUNIT +*> \verbatim +*> NUNIT is INTEGER +*> The unit number for output. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2011 +* +*> \ingroup double_lin +* +* ===================================================================== + SUBROUTINE CERRLQTP( PATH, NUNIT ) + IMPLICIT NONE +* +* -- LAPACK test routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + CHARACTER*3 PATH + INTEGER NUNIT +* .. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER NMAX + PARAMETER ( NMAX = 2 ) +* .. +* .. Local Scalars .. + INTEGER I, INFO, J +* .. +* .. Local Arrays .. + COMPLEX A( NMAX, NMAX ), T( NMAX, NMAX ), W( NMAX ), + $ B( NMAX, NMAX ), C( NMAX, NMAX ) +* .. +* .. External Subroutines .. + EXTERNAL ALAESM, CHKXER, CTPLQT2, CTPLQT, + $ CTPMLQT +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, NOUT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NOUT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Intrinsic Functions .. + INTRINSIC REAL, CMPLX +* .. +* .. Executable Statements .. +* + NOUT = NUNIT + WRITE( NOUT, FMT = * ) +* +* Set the variables to innocuous values. +* + DO J = 1, NMAX + DO I = 1, NMAX + A( I, J ) = 1.E0 / CMPLX( REAL( I+J ), 0.E0 ) + C( I, J ) = 1.E0 / CMPLX( REAL( I+J ), 0.E0 ) + T( I, J ) = 1.E0 / CMPLX( REAL( I+J ), 0.E0 ) + END DO + W( J ) = 0.E0 + END DO + OK = .TRUE. +* +* Error exits for TPLQT factorization +* +* CTPLQT +* + SRNAMT = 'CTPLQT' + INFOT = 1 + CALL CTPLQT( -1, 1, 0, 1, A, 1, B, 1, T, 1, W, INFO ) + CALL CHKXER( 'CTPLQT', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CTPLQT( 1, -1, 0, 1, A, 1, B, 1, T, 1, W, INFO ) + CALL CHKXER( 'CTPLQT', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CTPLQT( 0, 1, -1, 1, A, 1, B, 1, T, 1, W, INFO ) + CALL CHKXER( 'CTPLQT', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CTPLQT( 0, 1, 1, 1, A, 1, B, 1, T, 1, W, INFO ) + CALL CHKXER( 'CTPLQT', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CTPLQT( 0, 1, 0, 0, A, 1, B, 1, T, 1, W, INFO ) + CALL CHKXER( 'CTPLQT', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CTPLQT( 1, 1, 0, 2, A, 1, B, 1, T, 1, W, INFO ) + CALL CHKXER( 'CTPLQT', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL CTPLQT( 2, 1, 0, 2, A, 1, B, 1, T, 1, W, INFO ) + CALL CHKXER( 'CTPLQT', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL CTPLQT( 2, 1, 0, 1, A, 2, B, 1, T, 1, W, INFO ) + CALL CHKXER( 'CTPLQT', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL CTPLQT( 2, 2, 1, 2, A, 2, B, 2, T, 1, W, INFO ) + CALL CHKXER( 'CTPLQT', INFOT, NOUT, LERR, OK ) +* +* CTPLQT2 +* + SRNAMT = 'CTPLQT2' + INFOT = 1 + CALL CTPLQT2( -1, 0, 0, A, 1, B, 1, T, 1, INFO ) + CALL CHKXER( 'CTPLQT2', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CTPLQT2( 0, -1, 0, A, 1, B, 1, T, 1, INFO ) + CALL CHKXER( 'CTPLQT2', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CTPLQT2( 0, 0, -1, A, 1, B, 1, T, 1, INFO ) + CALL CHKXER( 'CTPLQT2', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL CTPLQT2( 2, 2, 0, A, 1, B, 2, T, 2, INFO ) + CALL CHKXER( 'CTPLQT2', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL CTPLQT2( 2, 2, 0, A, 2, B, 1, T, 2, INFO ) + CALL CHKXER( 'CTPLQT2', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL CTPLQT2( 2, 2, 0, A, 2, B, 2, T, 1, INFO ) + CALL CHKXER( 'CTPLQT2', INFOT, NOUT, LERR, OK ) +* +* CTPMLQT +* + SRNAMT = 'CTPMLQT' + INFOT = 1 + CALL CTPMLQT( '/', 'N', 0, 0, 0, 0, 1, A, 1, T, 1, B, 1, C, 1, + $ W, INFO ) + CALL CHKXER( 'CTPMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CTPMLQT( 'L', '/', 0, 0, 0, 0, 1, A, 1, T, 1, B, 1, C, 1, + $ W, INFO ) + CALL CHKXER( 'CTPMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CTPMLQT( 'L', 'N', -1, 0, 0, 0, 1, A, 1, T, 1, B, 1, C, 1, + $ W, INFO ) + CALL CHKXER( 'CTPMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CTPMLQT( 'L', 'N', 0, -1, 0, 0, 1, A, 1, T, 1, B, 1, C, 1, + $ W, INFO ) + CALL CHKXER( 'CTPMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL CTPMLQT( 'L', 'N', 0, 0, -1, 0, 1, A, 1, T, 1, B, 1, C, 1, + $ W, INFO ) + INFOT = 6 + CALL CTPMLQT( 'L', 'N', 0, 0, 0, -1, 1, A, 1, T, 1, B, 1, C, 1, + $ W, INFO ) + CALL CHKXER( 'CTPMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL CTPMLQT( 'L', 'N', 0, 0, 0, 0, 0, A, 1, T, 1, B, 1, C, 1, + $ W, INFO ) + CALL CHKXER( 'CTPMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL CTPMLQT( 'R', 'N', 2, 2, 2, 1, 1, A, 1, T, 1, B, 1, C, 1, + $ W, INFO ) + CALL CHKXER( 'CTPMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL CTPMLQT( 'R', 'N', 1, 1, 1, 1, 1, A, 1, T, 0, B, 1, C, 1, + $ W, INFO ) + CALL CHKXER( 'CTPMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 13 + CALL CTPMLQT( 'L', 'N', 1, 1, 1, 1, 1, A, 1, T, 1, B, 0, C, 1, + $ W, INFO ) + CALL CHKXER( 'CTPMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 15 + CALL CTPMLQT( 'L', 'N', 1, 1, 1, 1, 1, A, 1, T, 1, B, 1, C, 0, + $ W, INFO ) + CALL CHKXER( 'CTPMLQT', INFOT, NOUT, LERR, OK ) +* +* Print a summary line. +* + CALL ALAESM( PATH, OK, NOUT ) +* + RETURN +* +* End of CERRLQT +* + END diff --git a/TESTING/LIN/cerrtsqr.f b/TESTING/LIN/cerrtsqr.f new file mode 100644 index 00000000..3ca8b379 --- /dev/null +++ b/TESTING/LIN/cerrtsqr.f @@ -0,0 +1,243 @@ +*> \brief \b CERRTSQR +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CERRTSQR( PATH, NUNIT ) +* +* .. Scalar Arguments .. +* CHARACTER*3 PATH +* INTEGER NUNIT +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CERRTSQR tests the error exits for the COMPLEX routines +*> that use the TSQR decomposition of a general matrix. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] PATH +*> \verbatim +*> PATH is CHARACTER*3 +*> The LAPACK path name for the routines to be tested. +*> \endverbatim +*> +*> \param[in] NUNIT +*> \verbatim +*> NUNIT is INTEGER +*> The unit number for output. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Zenver +*> \author NAG Ltd. +* +*> \date November 2011 +* +*> \ingroup double_lin +* +* ===================================================================== + SUBROUTINE CERRTSQR( PATH, NUNIT ) + IMPLICIT NONE +* +* -- LAPACK test routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + CHARACTER*3 PATH + INTEGER NUNIT +* .. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER NMAX + PARAMETER ( NMAX = 2 ) +* .. +* .. Local Scalars .. + INTEGER I, INFO, J, NB +* .. +* .. Local Arrays .. + COMPLEX A( NMAX, NMAX ), T( NMAX, NMAX ), W( NMAX ), + $ C( NMAX, NMAX ), TAU(NMAX) +* .. +* .. External Subroutines .. + EXTERNAL ALAESM, CHKXER, CGEQR, + $ CGEMQR, CGELQ, CGEMLQ +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, NOUT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NOUT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Intrinsic Functions .. + INTRINSIC REAL +* .. +* .. Executable Statements .. +* + NOUT = NUNIT + WRITE( NOUT, FMT = * ) +* +* Set the variables to innocuous values. +* + DO J = 1, NMAX + DO I = 1, NMAX + A( I, J ) = 1.E0 / CMPLX( REAL( I+J ), 0.E0 ) + C( I, J ) = 1.E0 / CMPLX( REAL( I+J ), 0.E0 ) + T( I, J ) = 1.E0 / CMPLX( REAL( I+J ), 0.E0 ) + END DO + W( J ) = 0.E0 + END DO + OK = .TRUE. +* +* Error exits for TS factorization +* +* CGEQR +* + SRNAMT = 'CGEQR' + INFOT = 1 + CALL CGEQR( -1, 0, A, 1, TAU, 1, W, 1, INFO ) + CALL CHKXER( 'CGEQR', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CGEQR( 0, -1, A, 1, TAU, 1, W, 1, INFO ) + CALL CHKXER( 'CGEQR', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CGEQR( 1, 1, A, 0, TAU, 1, W, 1, INFO ) + CALL CHKXER( 'CGEQR', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL CGEQR( 3, 2, A, 3, TAU, 1, W, 1, INFO ) + CALL CHKXER( 'CGEQR', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL CGEQR( 3, 2, A, 3, TAU, 8, W, 0, INFO ) + CALL CHKXER( 'CGEQR', INFOT, NOUT, LERR, OK ) +* +* CGEMQR +* + TAU(1)=1 + TAU(2)=1 + SRNAMT = 'CGEMQR' + NB=1 + INFOT = 1 + CALL CGEMQR( '/', 'N', 0, 0, 0, A, 1, TAU, 1, C, 1, W, 1,INFO) + CALL CHKXER( 'CGEMQR', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CGEMQR( 'L', '/', 0, 0, 0, A, 1, TAU, 1, C, 1, W, 1,INFO) + CALL CHKXER( 'CGEMQR', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CGEMQR( 'L', 'N', -1, 0, 0, A, 1, TAU, 1, C, 1, W,1,INFO) + CALL CHKXER( 'CGEMQR', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CGEMQR( 'L', 'N', 0, -1, 0, A, 1, TAU, 1, C, 1, W,1,INFO) + CALL CHKXER( 'CGEMQR', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL CGEMQR( 'L', 'N', 0, 0, -1, A, 1, TAU, 1, C, 1, W,1,INFO) + CALL CHKXER( 'CGEMQR', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL CGEMQR( 'R', 'N', 0, 0, -1, A, 1, TAU, 1, C, 1, W,1,INFO) + CALL CHKXER( 'CGEMQR', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL CGEMQR( 'L', 'N', 2, 1, 0, A, 0, TAU, 1, C, 1, W, 1,INFO) + CALL CHKXER( 'CGEMQR', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL CGEMQR( 'R', 'N', 2, 2, 1, A, 1, TAU, 0, C, 1, W, 1,INFO) + CALL CHKXER( 'CGEMQR', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL CGEMQR( 'L', 'N', 2, 2, 1, A, 1, TAU, 0, C, 1, W, 1,INFO) + CALL CHKXER( 'CGEMQR', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL CGEMQR( 'L', 'N', 2, 1, 1, A, 1, TAU, 6, C, 0, W, 1,INFO) + CALL CHKXER( 'CGEMQR', INFOT, NOUT, LERR, OK ) + INFOT = 13 + CALL CGEMQR( 'L', 'N', 2, 2, 1, A, 2, TAU, 6, C, 2, W, 0,INFO) + CALL CHKXER( 'CGEMQR', INFOT, NOUT, LERR, OK ) +* +* CGELQ +* + SRNAMT = 'CGELQ' + INFOT = 1 + CALL CGELQ( -1, 0, A, 1, TAU, 1, W, 1, INFO ) + CALL CHKXER( 'CGELQ', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CGELQ( 0, -1, A, 1, TAU, 1, W, 1, INFO ) + CALL CHKXER( 'CGELQ', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CGELQ( 1, 1, A, 0, TAU, 1, W, 1, INFO ) + CALL CHKXER( 'CGELQ', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL CGELQ( 2, 3, A, 3, TAU, 1, W, 1, INFO ) + CALL CHKXER( 'CGELQ', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL CGELQ( 2, 3, A, 3, TAU, 8, W, 0, INFO ) + CALL CHKXER( 'CGELQ', INFOT, NOUT, LERR, OK ) +* +* CGEMLQ +* + TAU(1)=1 + TAU(2)=1 + SRNAMT = 'CGEMLQ' + NB=1 + INFOT = 1 + CALL CGEMLQ( '/', 'N', 0, 0, 0, A, 1, TAU, 1, C, 1, W, 1,INFO) + CALL CHKXER( 'CGEMLQ', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CGEMLQ( 'L', '/', 0, 0, 0, A, 1, TAU, 1, C, 1, W, 1,INFO) + CALL CHKXER( 'CGEMLQ', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CGEMLQ( 'L', 'N', -1, 0, 0, A, 1, TAU, 1, C, 1, W,1,INFO) + CALL CHKXER( 'CGEMLQ', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CGEMLQ( 'L', 'N', 0, -1, 0, A, 1, TAU, 1, C, 1, W,1,INFO) + CALL CHKXER( 'CGEMLQ', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL CGEMLQ( 'L', 'N', 0, 0, -1, A, 1, TAU, 1, C, 1, W,1,INFO) + CALL CHKXER( 'CGEMLQ', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL CGEMLQ( 'R', 'N', 0, 0, -1, A, 1, TAU, 1, C, 1, W,1,INFO) + CALL CHKXER( 'CGEMLQ', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL CGEMLQ( 'L', 'N', 1, 2, 0, A, 0, TAU, 1, C, 1, W, 1,INFO) + CALL CHKXER( 'CGEMLQ', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL CGEMLQ( 'R', 'N', 2, 2, 1, A, 1, TAU, 0, C, 1, W, 1,INFO) + CALL CHKXER( 'CGEMLQ', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL CGEMLQ( 'L', 'N', 2, 2, 1, A, 1, TAU, 0, C, 1, W, 1,INFO) + CALL CHKXER( 'CGEMLQ', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL CGEMLQ( 'L', 'N', 1, 2, 1, A, 1, TAU, 6, C, 0, W, 1,INFO) + CALL CHKXER( 'CGEMLQ', INFOT, NOUT, LERR, OK ) + INFOT = 13 + CALL CGEMLQ( 'L', 'N', 2, 2, 1, A, 2, TAU, 6, C, 2, W, 0,INFO) + CALL CHKXER( 'CGEMLQ', INFOT, NOUT, LERR, OK ) +* +* Print a summary line. +* + CALL ALAESM( PATH, OK, NOUT ) +* + RETURN +* +* End of CERRTSQR +* + END diff --git a/TESTING/LIN/clqt04.f b/TESTING/LIN/clqt04.f new file mode 100644 index 00000000..cdab2dfd --- /dev/null +++ b/TESTING/LIN/clqt04.f @@ -0,0 +1,262 @@ +*> \brief \b DLQT04 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CLQT04(M,N,NB,RESULT) +* +* .. Scalar Arguments .. +* INTEGER M, N, NB +* .. Return values .. +* REAL RESULT(6) +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CLQT04 tests CGELQT and CGEMLQT. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> Number of rows in test matrix. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> Number of columns in test matrix. +*> \endverbatim +*> +*> \param[in] NB +*> \verbatim +*> NB is INTEGER +*> Block size of test matrix. NB <= Min(M,N). +*> \endverbatim +*> +*> \param[out] RESULT +*> \verbatim +*> RESULT is DOUBLE PRECISION array, dimension (6) +*> Results of each of the six tests below. +*> +*> RESULT(1) = | A - L Q | +*> RESULT(2) = | I - Q Q^H | +*> RESULT(3) = | Q C - Q C | +*> RESULT(4) = | Q^H C - Q^H C | +*> RESULT(5) = | C Q - C Q | +*> RESULT(6) = | C Q^H - C Q^H | +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date April 2012 +* +*> \ingroup double_lin +* +* ===================================================================== + SUBROUTINE CLQT04(M,N,NB,RESULT) + IMPLICIT NONE +* +* -- LAPACK test routine (version 3.4.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* April 2012 +* +* .. Scalar Arguments .. + INTEGER M, N, NB +* .. Return values .. + REAL RESULT(6) +* +* ===================================================================== +* +* .. +* .. Local allocatable arrays + COMPLEX, ALLOCATABLE :: AF(:,:), Q(:,:), + $ L(:,:), RWORK(:), WORK( : ), T(:,:), + $ CF(:,:), DF(:,:), A(:,:), C(:,:), D(:,:) +* +* .. Parameters .. + REAL ZERO + COMPLEX ONE, CZERO + PARAMETER( ZERO = 0.0) + PARAMETER( ONE = (1.0,0.0), CZERO=(0.0,0.0) ) +* .. +* .. Local Scalars .. + INTEGER INFO, J, K, LL, LWORK, LDT + REAL ANORM, EPS, RESID, CNORM, DNORM +* .. +* .. Local Arrays .. + INTEGER ISEED( 4 ) +* .. +* .. External Functions .. + REAL SLAMCH + REAL CLANGE, CLANSY + LOGICAL LSAME + EXTERNAL SLAMCH, CLANGE, CLANSY, LSAME +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Data statements .. + DATA ISEED / 1988, 1989, 1990, 1991 / +* + EPS = SLAMCH( 'Epsilon' ) + K = MIN(M,N) + LL = MAX(M,N) + LWORK = MAX(2,LL)*MAX(2,LL)*NB +* +* Dynamically allocate local arrays +* + ALLOCATE ( A(M,N), AF(M,N), Q(N,N), L(LL,N), RWORK(LL), + $ WORK(LWORK), T(NB,N), C(M,N), CF(M,N), + $ D(N,M), DF(N,M) ) +* +* Put random numbers into A and copy to AF +* + LDT=NB + DO J=1,N + CALL CLARNV( 2, ISEED, M, A( 1, J ) ) + END DO + CALL CLACPY( 'Full', M, N, A, M, AF, M ) +* +* Factor the matrix A in the array AF. +* + CALL CGELQT( M, N, NB, AF, M, T, LDT, WORK, INFO ) +* +* Generate the n-by-n matrix Q +* + CALL CLASET( 'Full', N, N, CZERO, ONE, Q, N ) + CALL CGEMLQT( 'R', 'N', N, N, K, NB, AF, M, T, LDT, Q, N, + $ WORK, INFO ) +* +* Copy L +* + CALL CLASET( 'Full', LL, N, CZERO, CZERO, L, LL ) + CALL CLACPY( 'Lower', M, N, AF, M, L, LL ) +* +* Compute |L - A*Q'| / |A| and store in RESULT(1) +* + CALL CGEMM( 'N', 'C', M, N, N, -ONE, A, M, Q, N, ONE, L, LL ) + ANORM = CLANGE( '1', M, N, A, M, RWORK ) + RESID = CLANGE( '1', M, N, L, LL, RWORK ) + IF( ANORM.GT.ZERO ) THEN + RESULT( 1 ) = RESID / (EPS*MAX(1,M)*ANORM) + ELSE + RESULT( 1 ) = ZERO + END IF +* +* Compute |I - Q'*Q| and store in RESULT(2) +* + CALL CLASET( 'Full', N, N, CZERO, ONE, L, LL ) + CALL CHERK( 'U', 'C', N, N, REAL(-ONE), Q, N, REAL(ONE), L, LL) + RESID = CLANSY( '1', 'Upper', N, L, LL, RWORK ) + RESULT( 2 ) = RESID / (EPS*MAX(1,N)) +* +* Generate random m-by-n matrix C and a copy CF +* + DO J=1,M + CALL CLARNV( 2, ISEED, N, D( 1, J ) ) + END DO + DNORM = CLANGE( '1', N, M, D, N, RWORK) + CALL CLACPY( 'Full', N, M, D, N, DF, N ) +* +* Apply Q to C as Q*C +* + CALL CGEMLQT( 'L', 'N', N, M, K, NB, AF, M, T, NB, DF, N, + $ WORK, INFO) +* +* Compute |Q*D - Q*D| / |D| +* + CALL CGEMM( 'N', 'N', N, M, N, -ONE, Q, N, D, N, ONE, DF, N ) + RESID = CLANGE( '1', N, M, DF, N, RWORK ) + IF( DNORM.GT.ZERO ) THEN + RESULT( 3 ) = RESID / (EPS*MAX(1,M)*DNORM) + ELSE + RESULT( 3 ) = ZERO + END IF +* +* Copy D into DF again +* + CALL CLACPY( 'Full', N, M, D, N, DF, N ) +* +* Apply Q to D as QT*D +* + CALL CGEMLQT( 'L', 'C', N, M, K, NB, AF, M, T, NB, DF, N, + $ WORK, INFO) +* +* Compute |QT*D - QT*D| / |D| +* + CALL CGEMM( 'C', 'N', N, M, N, -ONE, Q, N, D, N, ONE, DF, N ) + RESID = CLANGE( '1', N, M, DF, N, RWORK ) + IF( DNORM.GT.ZERO ) THEN + RESULT( 4 ) = RESID / (EPS*MAX(1,M)*DNORM) + ELSE + RESULT( 4 ) = ZERO + END IF +* +* Generate random n-by-m matrix D and a copy DF +* + DO J=1,N + CALL CLARNV( 2, ISEED, M, C( 1, J ) ) + END DO + CNORM = CLANGE( '1', M, N, C, M, RWORK) + CALL CLACPY( 'Full', M, N, C, M, CF, M ) +* +* Apply Q to C as C*Q +* + CALL CGEMLQT( 'R', 'N', M, N, K, NB, AF, M, T, NB, CF, M, + $ WORK, INFO) +* +* Compute |C*Q - C*Q| / |C| +* + CALL CGEMM( 'N', 'N', M, N, N, -ONE, C, M, Q, N, ONE, CF, M ) + RESID = CLANGE( '1', N, M, DF, N, RWORK ) + IF( CNORM.GT.ZERO ) THEN + RESULT( 5 ) = RESID / (EPS*MAX(1,M)*DNORM) + ELSE + RESULT( 5 ) = ZERO + END IF +* +* Copy C into CF again +* + CALL CLACPY( 'Full', M, N, C, M, CF, M ) +* +* Apply Q to D as D*QT +* + CALL CGEMLQT( 'R', 'C', M, N, K, NB, AF, M, T, NB, CF, M, + $ WORK, INFO) +* +* Compute |C*QT - C*QT| / |C| +* + CALL CGEMM( 'N', 'C', M, N, N, -ONE, C, M, Q, N, ONE, CF, M ) + RESID = CLANGE( '1', M, N, CF, M, RWORK ) + IF( CNORM.GT.ZERO ) THEN + RESULT( 6 ) = RESID / (EPS*MAX(1,M)*DNORM) + ELSE + RESULT( 6 ) = ZERO + END IF +* +* Deallocate all arrays +* + DEALLOCATE ( A, AF, Q, L, RWORK, WORK, T, C, D, CF, DF) +* + RETURN + END + diff --git a/TESTING/LIN/clqt05.f b/TESTING/LIN/clqt05.f new file mode 100644 index 00000000..22ffcc05 --- /dev/null +++ b/TESTING/LIN/clqt05.f @@ -0,0 +1,289 @@ +*> \brief \b CLQT05 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CLQT05(M,N,L,NB,RESULT) +* +* .. Scalar Arguments .. +* INTEGER LWORK, M, N, L, NB, LDT +* .. Return values .. +* DOUBLE PRECISION RESULT(6) +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CQRT05 tests CTPLQT and CTPMLQT. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> Number of rows in lower part of the test matrix. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> Number of columns in test matrix. +*> \endverbatim +*> +*> \param[in] L +*> \verbatim +*> L is INTEGER +*> The number of rows of the upper trapezoidal part the +*> lower test matrix. 0 <= L <= M. +*> \endverbatim +*> +*> \param[in] NB +*> \verbatim +*> NB is INTEGER +*> Block size of test matrix. NB <= N. +*> \endverbatim +*> +*> \param[out] RESULT +*> \verbatim +*> RESULT is DOUBLE PRECISION array, dimension (6) +*> Results of each of the six tests below. +*> +*> RESULT(1) = | A - Q R | +*> RESULT(2) = | I - Q^H Q | +*> RESULT(3) = | Q C - Q C | +*> RESULT(4) = | Q^H C - Q^H C | +*> RESULT(5) = | C Q - C Q | +*> RESULT(6) = | C Q^H - C Q^H | +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date April 2012 +* +*> \ingroup double_lin +* +* ===================================================================== + SUBROUTINE CLQT05(M,N,L,NB,RESULT) + IMPLICIT NONE +* +* -- LAPACK test routine (version 3.4.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* April 2012 +* +* .. Scalar Arguments .. + INTEGER LWORK, M, N, L, NB, LDT +* .. Return values .. + REAL RESULT(6) +* +* ===================================================================== +* +* .. +* .. Local allocatable arrays + COMPLEX, ALLOCATABLE :: AF(:,:), Q(:,:), + $ R(:,:), RWORK(:), WORK( : ), T(:,:), + $ CF(:,:), DF(:,:), A(:,:), C(:,:), D(:,:) +* +* .. Parameters .. + REAL ZERO + COMPLEX ONE, CZERO + PARAMETER( ZERO = 0.0, ONE = (1.0,0.0), CZERO=(0.0,0.0) ) +* .. +* .. Local Scalars .. + INTEGER INFO, J, K, N2, NP1,i + REAL ANORM, EPS, RESID, CNORM, DNORM +* .. +* .. Local Arrays .. + INTEGER ISEED( 4 ) +* .. +* .. External Functions .. + REAL SLAMCH + REAL CLANGE, CLANSY + LOGICAL LSAME + EXTERNAL SLAMCH, CLANGE, CLANSY, LSAME +* .. +* .. Data statements .. + DATA ISEED / 1988, 1989, 1990, 1991 / +* + EPS = SLAMCH( 'Epsilon' ) + K = M + N2 = M+N + IF( N.GT.0 ) THEN + NP1 = M+1 + ELSE + NP1 = 1 + END IF + LWORK = N2*N2*NB +* +* Dynamically allocate all arrays +* + ALLOCATE(A(M,N2),AF(M,N2),Q(N2,N2),R(N2,N2),RWORK(N2), + $ WORK(LWORK),T(NB,M),C(N2,M),CF(N2,M), + $ D(M,N2),DF(M,N2) ) +* +* Put random stuff into A +* + LDT=NB + CALL CLASET( 'Full', M, N2, CZERO, CZERO, A, M ) + CALL CLASET( 'Full', NB, M, CZERO, CZERO, T, NB ) + DO J=1,M + CALL CLARNV( 2, ISEED, M-J+1, A( J, J ) ) + END DO + IF( N.GT.0 ) THEN + DO J=1,N-L + CALL CLARNV( 2, ISEED, M, A( 1, MIN(N+M,M+1) + J - 1 ) ) + END DO + END IF + IF( L.GT.0 ) THEN + DO J=1,L + CALL CLARNV( 2, ISEED, M-J+1, A( J, MIN(N+M,N+M-L+1) + $ + J - 1 ) ) + END DO + END IF +* +* Copy the matrix A to the array AF. +* + CALL CLACPY( 'Full', M, N2, A, M, AF, M ) +* +* Factor the matrix A in the array AF. +* + CALL CTPLQT( M,N,L,NB,AF,M,AF(1,NP1),M,T,LDT,WORK,INFO) +* +* Generate the (M+N)-by-(M+N) matrix Q by applying H to I +* + CALL CLASET( 'Full', N2, N2, CZERO, ONE, Q, N2 ) + CALL CGEMLQT( 'L', 'N', N2, N2, K, NB, AF, M, T, LDT, Q, N2, + $ WORK, INFO ) +* +* Copy L +* + CALL CLASET( 'Full', N2, N2, CZERO, CZERO, R, N2 ) + CALL CLACPY( 'Lower', M, N2, AF, M, R, N2 ) +* +* Compute |L - A*Q*C| / |A| and store in RESULT(1) +* + CALL CGEMM( 'N', 'C', M, N2, N2, -ONE, A, M, Q, N2, ONE, R, N2) + ANORM = CLANGE( '1', M, N2, A, M, RWORK ) + RESID = CLANGE( '1', M, N2, R, N2, RWORK ) + IF( ANORM.GT.ZERO ) THEN + RESULT( 1 ) = RESID / (EPS*ANORM*MAX(1,N2)) + ELSE + RESULT( 1 ) = ZERO + END IF +* +* Compute |I - Q*Q'| and store in RESULT(2) +* + CALL CLASET( 'Full', N2, N2, CZERO, ONE, R, N2 ) + CALL CHERK( 'U', 'N', N2, N2, REAL(-ONE), Q, N2, REAL(ONE), + $ R, N2 ) + RESID = CLANSY( '1', 'Upper', N2, R, N2, RWORK ) + RESULT( 2 ) = RESID / (EPS*MAX(1,N2)) +* +* Generate random m-by-n matrix C and a copy CF +* + CALL CLASET( 'Full', N2, M, CZERO, ONE, C, N2 ) + DO J=1,M + CALL CLARNV( 2, ISEED, N2, C( 1, J ) ) + END DO + CNORM = CLANGE( '1', N2, M, C, N2, RWORK) + CALL CLACPY( 'Full', N2, M, C, N2, CF, N2 ) +* +* Apply Q to C as Q*C +* + CALL CTPMLQT( 'L','N', N,M,K,L,NB,AF(1, NP1),M,T,LDT,CF,N2, + $ CF(NP1,1),N2,WORK,INFO) +* +* Compute |Q*C - Q*C| / |C| +* + CALL CGEMM( 'N', 'N', N2, M, N2, -ONE, Q, N2, C, N2, ONE, CF, N2 ) + RESID = CLANGE( '1', N2, M, CF, N2, RWORK ) + IF( CNORM.GT.ZERO ) THEN + RESULT( 3 ) = RESID / (EPS*MAX(1,N2)*CNORM) + ELSE + RESULT( 3 ) = ZERO + END IF + +* +* Copy C into CF again +* + CALL CLACPY( 'Full', N2, M, C, N2, CF, N2 ) +* +* Apply Q to C as QT*C +* + CALL CTPMLQT( 'L','C',N,M,K,L,NB,AF(1,NP1),M,T,LDT,CF,N2, + $ CF(NP1,1),N2,WORK,INFO) +* +* Compute |QT*C - QT*C| / |C| +* + CALL CGEMM('C','N',N2,M,N2,-ONE,Q,N2,C,N2,ONE,CF,N2) + RESID = CLANGE( '1', N2, M, CF, N2, RWORK ) + + IF( CNORM.GT.ZERO ) THEN + RESULT( 4 ) = RESID / (EPS*MAX(1,N2)*CNORM) + ELSE + RESULT( 4 ) = ZERO + END IF +* +* Generate random m-by-n matrix D and a copy DF +* + DO J=1,N2 + CALL CLARNV( 2, ISEED, M, D( 1, J ) ) + END DO + DNORM = CLANGE( '1', M, N2, D, M, RWORK) + CALL CLACPY( 'Full', M, N2, D, M, DF, M ) +* +* Apply Q to D as D*Q +* + CALL CTPMLQT('R','N',M,N,K,L,NB,AF(1,NP1),M,T,LDT,DF,M, + $ DF(1,NP1),M,WORK,INFO) +* +* Compute |D*Q - D*Q| / |D| +* + CALL CGEMM('N','N',M,N2,N2,-ONE,D,M,Q,N2,ONE,DF,M) + RESID = CLANGE('1',M, N2,DF,M,RWORK ) + IF( CNORM.GT.ZERO ) THEN + RESULT( 5 ) = RESID / (EPS*MAX(1,N2)*DNORM) + ELSE + RESULT( 5 ) = ZERO + END IF +* +* Copy D into DF again +* + CALL CLACPY('Full',M,N2,D,M,DF,M ) +* +* Apply Q to D as D*QT +* + CALL CTPMLQT('R','C',M,N,K,L,NB,AF(1,NP1),M,T,LDT,DF,M, + $ DF(1,NP1),M,WORK,INFO) + +* +* Compute |D*QT - D*QT| / |D| +* + CALL CGEMM( 'N', 'C', M, N2, N2, -ONE, D, M, Q, N2, ONE, DF, M ) + RESID = CLANGE( '1', M, N2, DF, M, RWORK ) + IF( CNORM.GT.ZERO ) THEN + RESULT( 6 ) = RESID / (EPS*MAX(1,N2)*DNORM) + ELSE + RESULT( 6 ) = ZERO + END IF +* +* Deallocate all arrays +* + DEALLOCATE ( A, AF, Q, R, RWORK, WORK, T, C, D, CF, DF) + RETURN + END
\ No newline at end of file diff --git a/TESTING/LIN/ctsqr01.f b/TESTING/LIN/ctsqr01.f new file mode 100644 index 00000000..a94f89f2 --- /dev/null +++ b/TESTING/LIN/ctsqr01.f @@ -0,0 +1,427 @@ +*> \brief \b CTSQR01 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CTSQR01(TSSW, M,N, MB, NB, RESULT) +* +* .. Scalar Arguments .. +* INTEGER M, N, MB +* .. Return values .. +* REAL RESULT(6) +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DTSQR01 tests DGEQR , DGELQ, DGEMLQ and DGEMQR. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] TSSW +*> \verbatim +*> TSSW is CHARACTER +*> 'TS' for testing tall skinny QR +*> and anything else for testing short wide LQ +*> \endverbatim +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> Number of rows in test matrix. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> Number of columns in test matrix. +*> \endverbatim +*> \param[in] MB +*> \verbatim +*> MB is INTEGER +*> Number of row in row block in test matrix. +*> \endverbatim +*> +*> \param[in] NB +*> \verbatim +*> NB is INTEGER +*> Number of columns in column block test matrix. +*> \endverbatim +*> +*> \param[out] RESULT +*> \verbatim +*> RESULT is REAL array, dimension (6) +*> Results of each of the six tests below. +*> +*> RESULT(1) = | A - Q R | or | A - L Q | +*> RESULT(2) = | I - Q^H Q | or | I - Q Q^H | +*> RESULT(3) = | Q C - Q C | +*> RESULT(4) = | Q^H C - Q^H C | +*> RESULT(5) = | C Q - C Q | +*> RESULT(6) = | C Q^H - C Q^H | +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date April 2012 +* +* ===================================================================== + SUBROUTINE CTSQR01(TSSW, M, N, MB, NB, RESULT) + IMPLICIT NONE +* +* -- LAPACK test routine (version 3.4.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* April 2012 +* +* .. Scalar Arguments .. + CHARACTER TSSW + INTEGER M, N, MB, NB +* .. Return values .. + REAL RESULT(6) +* +* ===================================================================== +* +* .. +* .. Local allocatable arrays + COMPLEX, ALLOCATABLE :: AF(:,:), Q(:,:), + $ R(:,:), RWORK(:), WORK( : ), T(:), + $ CF(:,:), DF(:,:), A(:,:), C(:,:), D(:,:), LQ(:,:) +* +* .. Parameters .. + REAL ZERO + COMPLEX ONE, CZERO + PARAMETER( ZERO = 0.0, ONE = (1.0,0.0), CZERO=(0.0,0.0) ) +* .. +* .. Local Scalars .. + LOGICAL TESTZEROS, TS + INTEGER INFO, J, K, L, LWORK, LT ,MNB + REAL ANORM, EPS, RESID, CNORM, DNORM +* .. +* .. Local Arrays .. + INTEGER ISEED( 4 ) +* .. +* .. External Functions .. + REAL SLAMCH, CLANGE, CLANSY + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL SLAMCH, CLANGE, CLANSY, LSAME, ILAENV +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. Scalars in Common .. + CHARACTER*32 srnamt +* .. +* .. Common blocks .. + COMMON / srnamc / srnamt +* .. +* .. Data statements .. + DATA ISEED / 1988, 1989, 1990, 1991 / +* +* TEST TALL SKINNY OR SHORT WIDE +* + TS = LSAME(TSSW, 'TS') +* +* TEST MATRICES WITH HALF OF MATRIX BEING ZEROS +* + TESTZEROS = .FALSE. +* + EPS = SLAMCH( 'Epsilon' ) + K = MIN(M,N) + L = MAX(M,N,1) + MNB = MAX ( MB, NB) + LWORK = MAX(3,L)*MNB + IF((K.GE.MNB).OR.(MNB.GE.L))THEN + LT=MAX(1,L)*MNB+5 + ELSE + LT=MAX(1,(L-K)/(MNB-K)+1)*L*MNB+5 + END IF + +* +* Dynamically allocate local arrays +* + ALLOCATE ( A(M,N), AF(M,N), Q(L,L), R(M,L), RWORK(L), + $ WORK(LWORK), T(LT), C(M,N), CF(M,N), + $ D(N,M), DF(N,M), LQ(L,N) ) +* +* Put random numbers into A and copy to AF +* + DO J=1,N + CALL CLARNV( 2, ISEED, M, A( 1, J ) ) + END DO + IF (TESTZEROS) THEN + IF (M.GE.4) THEN + DO J=1,N + CALL CLARNV( 2, ISEED, M/2, A( M/4, J ) ) + END DO + END IF + END IF + CALL CLACPY( 'Full', M, N, A, M, AF, M ) +* + IF (TS) THEN +* +* Factor the matrix A in the array AF. +* + srnamt = 'CGEQR' + CALL CGEQR( M, N, AF, M, T, LT, WORK, LWORK, INFO ) +* +* Generate the m-by-m matrix Q +* + CALL CLASET( 'Full', M, M, CZERO, ONE, Q, M ) + srnamt = 'CGEMQR' + CALL CGEMQR( 'L', 'N', M, M, K, AF, M, T, LT, Q, M, + $ WORK, LWORK, INFO ) +* +* Copy R +* + CALL CLASET( 'Full', M, N, CZERO, CZERO, R, M ) + CALL CLACPY( 'Upper', M, N, AF, M, R, M ) +* +* Compute |R - Q'*A| / |A| and store in RESULT(1) +* + CALL CGEMM( 'C', 'N', M, N, M, -ONE, Q, M, A, M, ONE, R, M ) + ANORM = CLANGE( '1', M, N, A, M, RWORK ) + RESID = CLANGE( '1', M, N, R, M, RWORK ) + IF( ANORM.GT.ZERO ) THEN + RESULT( 1 ) = RESID / (EPS*MAX(1,M)*ANORM) + ELSE + RESULT( 1 ) = ZERO + END IF +* +* Compute |I - Q'*Q| and store in RESULT(2) +* + CALL CLASET( 'Full', M, M, CZERO, ONE, R, M ) + CALL CHERK( 'U', 'C', M, M, REAL(-ONE), Q, M, REAL(ONE), R, M ) + RESID = CLANSY( '1', 'Upper', M, R, M, RWORK ) + RESULT( 2 ) = RESID / (EPS*MAX(1,M)) +* +* Generate random m-by-n matrix C and a copy CF +* + DO J=1,N + CALL CLARNV( 2, ISEED, M, C( 1, J ) ) + END DO + CNORM = CLANGE( '1', M, N, C, M, RWORK) + CALL CLACPY( 'Full', M, N, C, M, CF, M ) +* +* Apply Q to C as Q*C +* + srnamt = 'CGEMQR' + CALL CGEMQR( 'L', 'N', M, N, K, AF, M, T, LT, CF, M, + $ WORK, LWORK, INFO) +* +* Compute |Q*C - Q*C| / |C| +* + CALL CGEMM( 'N', 'N', M, N, M, -ONE, Q, M, C, M, ONE, CF, M ) + RESID = CLANGE( '1', M, N, CF, M, RWORK ) + IF( CNORM.GT.ZERO ) THEN + RESULT( 3 ) = RESID / (EPS*MAX(1,M)*CNORM) + ELSE + RESULT( 3 ) = ZERO + END IF +* +* Copy C into CF again +* + CALL CLACPY( 'Full', M, N, C, M, CF, M ) +* +* Apply Q to C as QT*C +* + srnamt = 'CGEMQR' + CALL CGEMQR( 'L', 'C', M, N, K, AF, M, T, LT, CF, M, + $ WORK, LWORK, INFO) +* +* Compute |QT*C - QT*C| / |C| +* + CALL CGEMM( 'C', 'N', M, N, M, -ONE, Q, M, C, M, ONE, CF, M ) + RESID = CLANGE( '1', M, N, CF, M, RWORK ) + IF( CNORM.GT.ZERO ) THEN + RESULT( 4 ) = RESID / (EPS*MAX(1,M)*CNORM) + ELSE + RESULT( 4 ) = ZERO + END IF +* +* Generate random n-by-m matrix D and a copy DF +* + DO J=1,M + CALL CLARNV( 2, ISEED, N, D( 1, J ) ) + END DO + DNORM = CLANGE( '1', N, M, D, N, RWORK) + CALL CLACPY( 'Full', N, M, D, N, DF, N ) +* +* Apply Q to D as D*Q +* + srnamt = 'CGEMQR' + CALL CGEMQR( 'R', 'N', N, M, K, AF, M, T, LT, DF, N, + $ WORK, LWORK, INFO) +* +* Compute |D*Q - D*Q| / |D| +* + CALL CGEMM( 'N', 'N', N, M, M, -ONE, D, N, Q, M, ONE, DF, N ) + RESID = CLANGE( '1', N, M, DF, N, RWORK ) + IF( DNORM.GT.ZERO ) THEN + RESULT( 5 ) = RESID / (EPS*MAX(1,M)*DNORM) + ELSE + RESULT( 5 ) = ZERO + END IF +* +* Copy D into DF again +* + CALL CLACPY( 'Full', N, M, D, N, DF, N ) +* +* Apply Q to D as D*QT +* + CALL CGEMQR( 'R', 'C', N, M, K, AF, M, T, LT, DF, N, + $ WORK, LWORK, INFO) +* +* Compute |D*QT - D*QT| / |D| +* + CALL CGEMM( 'N', 'C', N, M, M, -ONE, D, N, Q, M, ONE, DF, N ) + RESID = CLANGE( '1', N, M, DF, N, RWORK ) + IF( CNORM.GT.ZERO ) THEN + RESULT( 6 ) = RESID / (EPS*MAX(1,M)*DNORM) + ELSE + RESULT( 6 ) = ZERO + END IF +* +* Short and wide +* + ELSE + srnamt = 'CGELQ' + CALL CGELQ( M, N, AF, M, T, LT, WORK, LWORK, INFO ) +* +* +* Generate the n-by-n matrix Q +* + CALL CLASET( 'Full', N, N, CZERO, ONE, Q, N ) + srnamt = 'CGEMLQ' + CALL CGEMLQ( 'R', 'N', N, N, K, AF, M, T, LT, Q, N, + $ WORK, LWORK, INFO ) +* +* Copy R +* + CALL CLASET( 'Full', M, N, CZERO, CZERO, LQ, L ) + CALL CLACPY( 'Lower', M, N, AF, M, LQ, L ) +* +* Compute |L - A*Q'| / |A| and store in RESULT(1) +* + CALL CGEMM( 'N', 'C', M, N, N, -ONE, A, M, Q, N, ONE, LQ, L ) + ANORM = CLANGE( '1', M, N, A, M, RWORK ) + RESID = CLANGE( '1', M, N, LQ, L, RWORK ) + IF( ANORM.GT.ZERO ) THEN + RESULT( 1 ) = RESID / (EPS*MAX(1,N)*ANORM) + ELSE + RESULT( 1 ) = ZERO + END IF +* +* Compute |I - Q'*Q| and store in RESULT(2) +* + CALL CLASET( 'Full', N, N, CZERO, ONE, LQ, L ) + CALL CHERK( 'U', 'C', N, N, REAL(-ONE), Q, N, REAL(ONE), LQ, L) + RESID = CLANSY( '1', 'Upper', N, LQ, L, RWORK ) + RESULT( 2 ) = RESID / (EPS*MAX(1,N)) +* +* Generate random m-by-n matrix C and a copy CF +* + DO J=1,M + CALL CLARNV( 2, ISEED, N, D( 1, J ) ) + END DO + DNORM = CLANGE( '1', N, M, D, N, RWORK) + CALL CLACPY( 'Full', N, M, D, N, DF, N ) +* +* Apply Q to C as Q*C +* + CALL CGEMLQ( 'L', 'N', N, M, K, AF, M, T, LT, DF, N, + $ WORK, LWORK, INFO) +* +* Compute |Q*D - Q*D| / |D| +* + CALL CGEMM( 'N', 'N', N, M, N, -ONE, Q, N, D, N, ONE, DF, N ) + RESID = CLANGE( '1', N, M, DF, N, RWORK ) + IF( DNORM.GT.ZERO ) THEN + RESULT( 3 ) = RESID / (EPS*MAX(1,N)*DNORM) + ELSE + RESULT( 3 ) = ZERO + END IF +* +* Copy D into DF again +* + CALL CLACPY( 'Full', N, M, D, N, DF, N ) +* +* Apply Q to D as QT*D +* + CALL CGEMLQ( 'L', 'C', N, M, K, AF, M, T, LT, DF, N, + $ WORK, LWORK, INFO) +* +* Compute |QT*D - QT*D| / |D| +* + CALL CGEMM( 'C', 'N', N, M, N, -ONE, Q, N, D, N, ONE, DF, N ) + RESID = CLANGE( '1', N, M, DF, N, RWORK ) + IF( DNORM.GT.ZERO ) THEN + RESULT( 4 ) = RESID / (EPS*MAX(1,N)*DNORM) + ELSE + RESULT( 4 ) = ZERO + END IF +* +* Generate random n-by-m matrix D and a copy DF +* + DO J=1,N + CALL CLARNV( 2, ISEED, M, C( 1, J ) ) + END DO + CNORM = CLANGE( '1', M, N, C, M, RWORK) + CALL CLACPY( 'Full', M, N, C, M, CF, M ) +* +* Apply Q to C as C*Q +* + CALL CGEMLQ( 'R', 'N', M, N, K, AF, M, T, LT, CF, M, + $ WORK, LWORK, INFO) +* +* Compute |C*Q - C*Q| / |C| +* + CALL CGEMM( 'N', 'N', M, N, N, -ONE, C, M, Q, N, ONE, CF, M ) + RESID = CLANGE( '1', N, M, DF, N, RWORK ) + IF( CNORM.GT.ZERO ) THEN + RESULT( 5 ) = RESID / (EPS*MAX(1,N)*CNORM) + ELSE + RESULT( 5 ) = ZERO + END IF +* +* Copy C into CF again +* + CALL CLACPY( 'Full', M, N, C, M, CF, M ) +* +* Apply Q to D as D*QT +* + CALL CGEMLQ( 'R', 'C', M, N, K, AF, M, T, LT, CF, M, + $ WORK, LWORK, INFO) +* +* Compute |C*QT - C*QT| / |C| +* + CALL CGEMM( 'N', 'C', M, N, N, -ONE, C, M, Q, N, ONE, CF, M ) + RESID = CLANGE( '1', M, N, CF, M, RWORK ) + IF( CNORM.GT.ZERO ) THEN + RESULT( 6 ) = RESID / (EPS*MAX(1,N)*CNORM) + ELSE + RESULT( 6 ) = ZERO + END IF +* + END IF +* +* Deallocate all arrays +* + DEALLOCATE ( A, AF, Q, R, RWORK, WORK, T, C, D, CF, DF) +* + RETURN + END
\ No newline at end of file diff --git a/TESTING/LIN/dchkaa.f b/TESTING/LIN/dchkaa.f index 9e7a14ab..70f9a52a 100644 --- a/TESTING/LIN/dchkaa.f +++ b/TESTING/LIN/dchkaa.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * PROGRAM DCHKAA -* +* * *> \par Purpose: * ============= @@ -49,7 +49,6 @@ *> DPP 9 List types on next line if 0 < NTYPES < 9 *> DPB 8 List types on next line if 0 < NTYPES < 8 *> DPT 12 List types on next line if 0 < NTYPES < 12 -*> DSA 10 List types on next line if 0 < NTYPES < 10 *> DSY 10 List types on next line if 0 < NTYPES < 10 *> DSR 10 List types on next line if 0 < NTYPES < 10 *> DSP 10 List types on next line if 0 < NTYPES < 10 @@ -95,10 +94,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -162,7 +161,9 @@ $ DCHKSY_ROOK, DCHKTB, DCHKTP, DCHKTR, DCHKTZ, $ DDRVGB, DDRVGE, DDRVGT, DDRVLS, DDRVPB, DDRVPO, $ DDRVPP, DDRVPT, DDRVSP, DDRVSY, DDRVSY_ROOK, - $ ILAVER, DCHKQRT, DCHKQRTP + $ ILAVER, DCHKQRT, DCHKQRTP, DCHKLQTP, DCHKTSQR, + $ DCHKLQT + * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -665,34 +666,6 @@ WRITE( NOUT, FMT = 9988 )PATH END IF * - ELSE IF( LSAMEN( 2, C2, 'SA' ) ) THEN -* -* SY: symmetric indefinite matrices, -* with partial (Aasen's) pivoting algorithm -* - NTYPES = 10 - CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) -* - IF( TSTCHK ) THEN - CALL DCHKSY_AASEN( DOTYPE, NN, NVAL, NNB2, NBVAL2, NNS, - $ NSVAL, THRESH, TSTERR, LDA, - $ A( 1, 1 ), A( 1, 2 ), A( 1, 3 ), - $ B( 1, 1 ), B( 1, 2 ), B( 1, 3 ), - $ WORK, RWORK, IWORK, NOUT ) - ELSE - WRITE( NOUT, FMT = 9989 )PATH - END IF -* - IF( TSTDRV ) THEN - CALL DDRVSY_AASEN( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, - $ LDA, A( 1, 1 ), A( 1, 2 ), A( 1, 3 ), - $ B( 1, 1 ), B( 1, 2 ), B( 1, 3 ), - $ WORK, RWORK, IWORK, NOUT ) - ELSE - WRITE( NOUT, FMT = 9988 )PATH - END IF -* -* ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN * * SP: symmetric indefinite packed matrices, @@ -891,13 +864,13 @@ ELSE WRITE( NOUT, FMT = 9989 )PATH END IF -* +* ELSE IF( LSAMEN( 2, C2, 'QT' ) ) THEN * * QT: QRT routines for general matrices * IF( TSTCHK ) THEN - CALL DCHKQRT( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, + CALL DCHKQRT( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, $ NBVAL, NOUT ) ELSE WRITE( NOUT, FMT = 9989 )PATH @@ -908,7 +881,40 @@ * QX: QRT routines for triangular-pentagonal matrices * IF( TSTCHK ) THEN - CALL DCHKQRTP( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, + CALL DCHKQRTP( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, + $ NBVAL, NOUT ) + ELSE + WRITE( NOUT, FMT = 9989 )PATH + END IF +* + ELSE IF( LSAMEN( 2, C2, 'TQ' ) ) THEN +* +* TQ: LQT routines for general matrices +* + IF( TSTCHK ) THEN + CALL DCHKLQT( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, + $ NBVAL, NOUT ) + ELSE + WRITE( NOUT, FMT = 9989 )PATH + END IF +* + ELSE IF( LSAMEN( 2, C2, 'XQ' ) ) THEN +* +* XQ: LQT routines for triangular-pentagonal matrices +* + IF( TSTCHK ) THEN + CALL DCHKLQTP( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, + $ NBVAL, NOUT ) + ELSE + WRITE( NOUT, FMT = 9989 )PATH + END IF +* + ELSE IF( LSAMEN( 2, C2, 'TS' ) ) THEN +* +* TS: QR routines for tall-skinny matrices +* + IF( TSTCHK ) THEN + CALL DCHKTSQR( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, $ NBVAL, NOUT ) ELSE WRITE( NOUT, FMT = 9989 )PATH diff --git a/TESTING/LIN/dchklqt.f b/TESTING/LIN/dchklqt.f new file mode 100644 index 00000000..1726090e --- /dev/null +++ b/TESTING/LIN/dchklqt.f @@ -0,0 +1,210 @@ +*> \brief \b DCHKLQT +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DCHKLQT( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, +* NBVAL, NOUT ) +* +* .. Scalar Arguments .. +* LOGICAL TSTERR +* INTEGER NM, NN, NNB, NOUT +* DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. +* INTEGER MVAL( * ), NBVAL( * ), NVAL( * ) +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DCHKLQT tests DGELQT and DGEMLQT. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] THRESH +*> \verbatim +*> THRESH is DOUBLE PRECISION +*> The threshold value for the test ratios. A result is +*> included in the output file if RESULT >= THRESH. To have +*> every test ratio printed, use THRESH = 0. +*> \endverbatim +*> +*> \param[in] TSTERR +*> \verbatim +*> TSTERR is LOGICAL +*> Flag that indicates whether error exits are to be tested. +*> \endverbatim +*> +*> \param[in] NM +*> \verbatim +*> NM is INTEGER +*> The number of values of M contained in the vector MVAL. +*> \endverbatim +*> +*> \param[in] MVAL +*> \verbatim +*> MVAL is INTEGER array, dimension (NM) +*> The values of the matrix row dimension M. +*> \endverbatim +*> +*> \param[in] NN +*> \verbatim +*> NN is INTEGER +*> The number of values of N contained in the vector NVAL. +*> \endverbatim +*> +*> \param[in] NVAL +*> \verbatim +*> NVAL is INTEGER array, dimension (NN) +*> The values of the matrix column dimension N. +*> \endverbatim +*> +*> \param[in] NNB +*> \verbatim +*> NNB is INTEGER +*> The number of values of NB contained in the vector NBVAL. +*> \endverbatim +*> +*> \param[in] NBVAL +*> \verbatim +*> NBVAL is INTEGER array, dimension (NBVAL) +*> The values of the blocksize NB. +*> \endverbatim +*> +*> \param[in] NOUT +*> \verbatim +*> NOUT is INTEGER +*> The unit number for output. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2011 +* +*> \ingroup double_lin +* +* ===================================================================== + SUBROUTINE DCHKLQT( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, + $ NBVAL, NOUT ) + IMPLICIT NONE +* +* -- LAPACK test routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + LOGICAL TSTERR + INTEGER NM, NN, NNB, NOUT + DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. + INTEGER MVAL( * ), NBVAL( * ), NVAL( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER NTESTS + PARAMETER ( NTESTS = 6 ) +* .. +* .. Local Scalars .. + CHARACTER*3 PATH + INTEGER I, J, K, T, M, N, NB, NFAIL, NERRS, NRUN, + $ MINMN +* +* .. Local Arrays .. + DOUBLE PRECISION RESULT( NTESTS ) +* .. +* .. External Subroutines .. + EXTERNAL ALAERH, ALAHD, ALASUM, DERRLQT, DLQT04 +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, NUNIT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NUNIT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Executable Statements .. +* +* Initialize constants +* + PATH( 1: 1 ) = 'D' + PATH( 2: 3 ) = 'TQ' + NRUN = 0 + NFAIL = 0 + NERRS = 0 +* +* Test the error exits +* + IF( TSTERR ) CALL DERRLQT( PATH, NOUT ) + INFOT = 0 +* +* Do for each value of M in MVAL. +* + DO I = 1, NM + M = MVAL( I ) +* +* Do for each value of N in NVAL. +* + DO J = 1, NN + N = NVAL( J ) +* +* Do for each possible value of NB +* + MINMN = MIN( M, N ) + DO K = 1, NNB + NB = NBVAL( K ) +* +* Test DGELQT and DGEMLQT +* + IF( (NB.LE.MINMN).AND.(NB.GT.0) ) THEN + CALL DLQT04( M, N, NB, RESULT ) +* +* Print information about the tests that did not +* pass the threshold. +* + DO T = 1, NTESTS + IF( RESULT( T ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 )M, N, NB, + $ T, RESULT( T ) + NFAIL = NFAIL + 1 + END IF + END DO + NRUN = NRUN + NTESTS + END IF + END DO + END DO + END DO +* +* Print a summary of the results. +* + CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) +* + 9999 FORMAT( ' M=', I5, ', N=', I5, ', NB=', I4, + $ ' test(', I2, ')=', G12.5 ) + RETURN +* +* End of DCHKLQT +* + END diff --git a/TESTING/LIN/dchklqtp.f b/TESTING/LIN/dchklqtp.f new file mode 100644 index 00000000..1cc82ec5 --- /dev/null +++ b/TESTING/LIN/dchklqtp.f @@ -0,0 +1,215 @@ +*> \brief \b DCHKLQTP +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DCHKLQTP( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, +* NBVAL, NOUT ) +* +* .. Scalar Arguments .. +* LOGICAL TSTERR +* INTEGER NM, NN, NNB, NOUT +* DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. +* INTEGER MVAL( * ), NBVAL( * ), NVAL( * ) +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DCHKLQTP tests DTPLQT and DTPMLQT. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] THRESH +*> \verbatim +*> THRESH is DOUBLE PRECISION +*> The threshold value for the test ratios. A result is +*> included in the output file if RESULT >= THRESH. To have +*> every test ratio printed, use THRESH = 0. +*> \endverbatim +*> +*> \param[in] TSTERR +*> \verbatim +*> TSTERR is LOGICAL +*> Flag that indicates whether error exits are to be tested. +*> \endverbatim +*> +*> \param[in] NM +*> \verbatim +*> NM is INTEGER +*> The number of values of M contained in the vector MVAL. +*> \endverbatim +*> +*> \param[in] MVAL +*> \verbatim +*> MVAL is INTEGER array, dimension (NM) +*> The values of the matrix row dimension M. +*> \endverbatim +*> +*> \param[in] NN +*> \verbatim +*> NN is INTEGER +*> The number of values of N contained in the vector NVAL. +*> \endverbatim +*> +*> \param[in] NVAL +*> \verbatim +*> NVAL is INTEGER array, dimension (NN) +*> The values of the matrix column dimension N. +*> \endverbatim +*> +*> \param[in] NNB +*> \verbatim +*> NNB is INTEGER +*> The number of values of NB contained in the vector NBVAL. +*> \endverbatim +*> +*> \param[in] NBVAL +*> \verbatim +*> NBVAL is INTEGER array, dimension (NBVAL) +*> The values of the blocksize NB. +*> \endverbatim +*> +*> \param[in] NOUT +*> \verbatim +*> NOUT is INTEGER +*> The unit number for output. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2011 +* +*> \ingroup double_lin +* +* ===================================================================== + SUBROUTINE DCHKLQTP( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, + $ NBVAL, NOUT ) + IMPLICIT NONE +* +* -- LAPACK test routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + LOGICAL TSTERR + INTEGER NM, NN, NNB, NOUT + DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. + INTEGER MVAL( * ), NBVAL( * ), NVAL( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER NTESTS + PARAMETER ( NTESTS = 6 ) +* .. +* .. Local Scalars .. + CHARACTER*3 PATH + INTEGER I, J, K, L, T, M, N, NB, NFAIL, NERRS, NRUN, + $ MINMN +* .. +* .. Local Arrays .. + DOUBLE PRECISION RESULT( NTESTS ) +* .. +* .. External Subroutines .. + EXTERNAL ALAERH, ALAHD, ALASUM, DERRLQTP, DLQT04 +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, NUNIT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NUNIT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Executable Statements .. +* +* Initialize constants +* + PATH( 1: 1 ) = 'D' + PATH( 2: 3 ) = 'XQ' + NRUN = 0 + NFAIL = 0 + NERRS = 0 +* +* Test the error exits +* + IF( TSTERR ) CALL DERRLQTP( PATH, NOUT ) + INFOT = 0 +* +* Do for each value of M +* + DO I = 1, NM + M = MVAL( I ) +* +* Do for each value of N +* + DO J = 1, NN + N = NVAL( J ) +* +* Do for each value of L +* + MINMN = MIN( M, N ) + DO L = 0, MINMN, MAX( MINMN, 1 ) +* +* Do for each possible value of NB +* + DO K = 1, NNB + NB = NBVAL( K ) +* +* Test DTPLQT and DTPMLQT +* + IF( (NB.LE.M).AND.(NB.GT.0) ) THEN + CALL DLQT05( M, N, L, NB, RESULT ) +* +* Print information about the tests that did not +* pass the threshold. +* + DO T = 1, NTESTS + IF( RESULT( T ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 )M, N, NB, L, + $ T, RESULT( T ) + NFAIL = NFAIL + 1 + END IF + END DO + NRUN = NRUN + NTESTS + END IF + END DO + END DO + END DO + END DO +* +* Print a summary of the results. +* + CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) +* + 9999 FORMAT( ' M=', I5, ', N=', I5, ', NB=', I4,' L=', I4, + $ ' test(', I2, ')=', G12.5 ) + RETURN +* +* End of DCHKQRTP +* + END diff --git a/TESTING/LIN/dchktsqr.f b/TESTING/LIN/dchktsqr.f new file mode 100644 index 00000000..0c3de46e --- /dev/null +++ b/TESTING/LIN/dchktsqr.f @@ -0,0 +1,257 @@ +*> \brief \b DCHKQRT +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DCHKTSQR( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, +* NBVAL, NOUT ) +* +* .. Scalar Arguments .. +* LOGICAL TSTERR +* INTEGER NM, NN, NNB, NOUT +* DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. +* INTEGER MVAL( * ), NBVAL( * ), NVAL( * ) +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DCHKTSQR tests DGETSQR and DORMTSQR. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] THRESH +*> \verbatim +*> THRESH is DOUBLE PRECISION +*> The threshold value for the test ratios. A result is +*> included in the output file if RESULT >= THRESH. To have +*> every test ratio printed, use THRESH = 0. +*> \endverbatim +*> +*> \param[in] TSTERR +*> \verbatim +*> TSTERR is LOGICAL +*> Flag that indicates whether error exits are to be tested. +*> \endverbatim +*> +*> \param[in] NM +*> \verbatim +*> NM is INTEGER +*> The number of values of M contained in the vector MVAL. +*> \endverbatim +*> +*> \param[in] MVAL +*> \verbatim +*> MVAL is INTEGER array, dimension (NM) +*> The values of the matrix row dimension M. +*> \endverbatim +*> +*> \param[in] NN +*> \verbatim +*> NN is INTEGER +*> The number of values of N contained in the vector NVAL. +*> \endverbatim +*> +*> \param[in] NVAL +*> \verbatim +*> NVAL is INTEGER array, dimension (NN) +*> The values of the matrix column dimension N. +*> \endverbatim +*> +*> \param[in] NNB +*> \verbatim +*> NNB is INTEGER +*> The number of values of NB contained in the vector NBVAL. +*> \endverbatim +*> +*> \param[in] NBVAL +*> \verbatim +*> NBVAL is INTEGER array, dimension (NBVAL) +*> The values of the blocksize NB. +*> \endverbatim +*> +*> \param[in] NOUT +*> \verbatim +*> NOUT is INTEGER +*> The unit number for output. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2011 +* +*> \ingroup double_lin +* +* ===================================================================== + SUBROUTINE DCHKTSQR( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, + $ NBVAL, NOUT ) + IMPLICIT NONE +* +* -- LAPACK test routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + LOGICAL TSTERR + INTEGER NM, NN, NNB, NOUT + DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. + INTEGER MVAL( * ), NBVAL( * ), NVAL( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER NTESTS + PARAMETER ( NTESTS = 6 ) +* .. +* .. Local Scalars .. + CHARACTER*3 PATH + INTEGER I, J, K, T, M, N, NB, NFAIL, NERRS, NRUN, INB, + $ MINMN, MB, IMB +* +* .. Local Arrays .. + DOUBLE PRECISION RESULT( NTESTS ) +* .. +* .. External Subroutines .. + EXTERNAL ALAERH, ALAHD, ALASUM, DERRTSQR, + $ DTSQR01, XLAENV +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, NUNIT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NUNIT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Executable Statements .. +* +* Initialize constants +* + PATH( 1: 1 ) = 'D' + PATH( 2: 3 ) = 'TS' + NRUN = 0 + NFAIL = 0 + NERRS = 0 +* +* Test the error exits +* + IF( TSTERR ) CALL DERRTSQR( PATH, NOUT ) + INFOT = 0 +* +* Do for each value of M in MVAL. +* + DO I = 1, NM + M = MVAL( I ) +* +* Do for each value of N in NVAL. +* + DO J = 1, NN + N = NVAL( J ) + IF (MIN(M,N).NE.0) THEN + DO INB = 1, NNB + MB = NBVAL( INB ) + CALL XLAENV( 1, MB ) + DO IMB = 1, NNB + NB = NBVAL( IMB ) + CALL XLAENV( 2, NB ) +* +* Test DGEQR and DGEMQR +* + CALL DTSQR01( 'TS', M, N, MB, NB, RESULT ) +* +* Print information about the tests that did not +* pass the threshold. +* + DO T = 1, NTESTS + IF( RESULT( T ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 )M, N, MB, NB, + $ T, RESULT( T ) + NFAIL = NFAIL + 1 + END IF + END DO + NRUN = NRUN + NTESTS + END DO + END DO + END IF + END DO + END DO +* +* Do for each value of M in MVAL. +* + DO I = 1, NM + M = MVAL( I ) +* +* Do for each value of N in NVAL. +* + DO J = 1, NN + N = NVAL( J ) + IF (MIN(M,N).NE.0) THEN + DO INB = 1, NNB + MB = NBVAL( INB ) + CALL XLAENV( 1, MB ) + DO IMB = 1, NNB + NB = NBVAL( IMB ) + CALL XLAENV( 2, NB ) +* +* Test DGEQR and DGEMQR +* + CALL DTSQR01( 'SW', M, N, MB, NB, RESULT ) +* +* Print information about the tests that did not +* pass the threshold. +* + DO T = 1, NTESTS + IF( RESULT( T ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9998 )M, N, MB, NB, + $ T, RESULT( T ) + NFAIL = NFAIL + 1 + END IF + END DO + NRUN = NRUN + NTESTS + END DO + END DO + END IF + END DO + END DO +* +* Print a summary of the results. +* + CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) +* + 9999 FORMAT( 'TS: M=', I5, ', N=', I5, ', MB=', I5, + $ ', NB=', I5,' test(', I2, ')=', G12.5 ) + 9998 FORMAT( 'SW: M=', I5, ', N=', I5, ', MB=', I5, + $ ', NB=', I5,' test(', I2, ')=', G12.5 ) + RETURN +* +* End of DCHKQRT +* + END
\ No newline at end of file diff --git a/TESTING/LIN/ddrvls.f b/TESTING/LIN/ddrvls.f index f92f3455..b9b798cb 100644 --- a/TESTING/LIN/ddrvls.f +++ b/TESTING/LIN/ddrvls.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE DDRVLS( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, NNB, * NBVAL, NXVAL, THRESH, TSTERR, A, COPYA, B, * COPYB, C, S, COPYS, WORK, IWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NM, NN, NNB, NNS, NOUT @@ -24,14 +24,14 @@ * DOUBLE PRECISION A( * ), B( * ), C( * ), COPYA( * ), COPYB( * ), * $ COPYS( * ), S( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= *> *> \verbatim *> -*> DDRVLS tests the least squares driver routines DGELS, DGELSS, DGELSY, +*> DDRVLS tests the least squares driver routines DGELS, DGETSLS, DGELSS, DGELSY, *> and DGELSD. *> \endverbatim * @@ -46,14 +46,14 @@ *> .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. *> The matrix of type j is generated as follows: *> j=1: A = U*D*V where U and V are random orthogonal matrices -*> and D has random entries (> 0.1) taken from a uniform +*> and D has random entries (> 0.1) taken from a uniform *> distribution (0,1). A is full rank. *> j=2: The same of 1, but A is scaled up. *> j=3: The same of 1, but A is scaled down. *> j=4: A = U*D*V where U and V are random orthogonal matrices *> and D has 3*min(M,N)/4 random entries (> 0.1) taken *> from a uniform distribution (0,1) and the remaining -*> entries set to 0. A is rank-deficient. +*> entries set to 0. A is rank-deficient. *> j=5: The same of 4, but A is scaled up. *> j=6: The same of 5, but A is scaled down. *> \endverbatim @@ -189,10 +189,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date November 2015 * @@ -225,7 +225,7 @@ * * .. Parameters .. INTEGER NTESTS - PARAMETER ( NTESTS = 14 ) + PARAMETER ( NTESTS = 16 ) INTEGER SMLSIZ PARAMETER ( SMLSIZ = 25 ) DOUBLE PRECISION ONE, TWO, ZERO @@ -234,10 +234,10 @@ * .. Local Scalars .. CHARACTER TRANS CHARACTER*3 PATH - INTEGER CRANK, I, IM, IN, INB, INFO, INS, IRANK, - $ ISCALE, ITRAN, ITYPE, J, K, LDA, LDB, LDWORK, - $ LWLSY, LWORK, M, MNMIN, N, NB, NCOLS, NERRS, - $ NFAIL, NLVL, NRHS, NROWS, NRUN, RANK + INTEGER CRANK, I, IM, IN, INB, INFO, INS, IRANK, + $ ISCALE, ITRAN, ITYPE, J, K, LDA, LDB, LDWORK, + $ LWLSY, LWORK, M, MNMIN, N, NB, NCOLS, NERRS, + $ NFAIL, NLVL, NRHS, NROWS, NRUN, RANK, MB, LWTS DOUBLE PRECISION EPS, NORMA, NORMB, RCOND * .. * .. Local Arrays .. @@ -308,8 +308,14 @@ * DO 140 IN = 1, NN N = NVAL( IN ) - MNMIN = MIN( M, N ) + MNMIN = MAX(MIN( M, N ),1) LDB = MAX( 1, M, N ) + MB = (MNMIN+1) + IF(MINMN.NE.MB) THEN + LWTS = (((LDB-MB)/(MB-MNMIN))*MNMIN+MNMIN*2)*MB+5 + ELSE + LWTS = 2*MINMN+5 + END IF * DO 130 INS = 1, NNS NRHS = NSVAL( INS ) @@ -317,7 +323,8 @@ $ DBLE( SMLSIZ+1 ) ) / LOG( TWO ) ) + 1, 0 ) LWORK = MAX( 1, ( M+NRHS )*( N+2 ), ( N+NRHS )*( M+2 ), $ M*N+4*MNMIN+MAX( M, N ), 12*MNMIN+2*MNMIN*SMLSIZ+ - $ 8*MNMIN*NLVL+MNMIN*NRHS+(SMLSIZ+1)**2 ) + $ 8*MNMIN*NLVL+MNMIN*NRHS+(SMLSIZ+1)**2,LWTS) + $ * DO 120 IRANK = 1, 2 DO 110 ISCALE = 1, 3 @@ -426,6 +433,110 @@ NRUN = NRUN + 2 30 CONTINUE 40 CONTINUE +* +* +* Test DGETSLS +* +* Generate a matrix of scaling type ISCALE +* + CALL DQRT13( ISCALE, M, N, COPYA, LDA, NORMA, + $ ISEED ) + DO 65 INB = 1, NNB + MB = NBVAL( INB ) + CALL XLAENV( 1, MB ) + DO 62 IMB = 1, NNB + NB = NBVAL( IMB ) + CALL XLAENV( 2, NB ) +* + DO 60 ITRAN = 1, 2 + IF( ITRAN.EQ.1 ) THEN + TRANS = 'N' + NROWS = M + NCOLS = N + ELSE + TRANS = 'T' + NROWS = N + NCOLS = M + END IF + LDWORK = MAX( 1, NCOLS ) +* +* Set up a consistent rhs +* + IF( NCOLS.GT.0 ) THEN + CALL DLARNV( 2, ISEED, NCOLS*NRHS, + $ WORK ) + CALL DSCAL( NCOLS*NRHS, + $ ONE / DBLE( NCOLS ), WORK, + $ 1 ) + END IF + CALL DGEMM( TRANS, 'No transpose', NROWS, + $ NRHS, NCOLS, ONE, COPYA, LDA, + $ WORK, LDWORK, ZERO, B, LDB ) + CALL DLACPY( 'Full', NROWS, NRHS, B, LDB, + $ COPYB, LDB ) +* +* Solve LS or overdetermined system +* + IF( M.GT.0 .AND. N.GT.0 ) THEN + CALL DLACPY( 'Full', M, N, COPYA, LDA, + $ A, LDA ) + CALL DLACPY( 'Full', NROWS, NRHS, + $ COPYB, LDB, B, LDB ) + END IF + SRNAMT = 'DGETSLS ' + CALL DGETSLS( TRANS, M, N, NRHS, A, + $ LDA, B, LDB, WORK, LWORK, INFO ) + IF( INFO.NE.0 ) + $ CALL ALAERH( PATH, 'DGETSLS ', INFO, 0, + $ TRANS, M, N, NRHS, -1, NB, + $ ITYPE, NFAIL, NERRS, + $ NOUT ) +* +* Check correctness of results +* + LDWORK = MAX( 1, NROWS ) + IF( NROWS.GT.0 .AND. NRHS.GT.0 ) + $ CALL DLACPY( 'Full', NROWS, NRHS, + $ COPYB, LDB, C, LDB ) + CALL DQRT16( TRANS, M, N, NRHS, COPYA, + $ LDA, B, LDB, C, LDB, WORK, + $ RESULT( 15 ) ) +* + IF( ( ITRAN.EQ.1 .AND. M.GE.N ) .OR. + $ ( ITRAN.EQ.2 .AND. M.LT.N ) ) THEN +* +* Solving LS system +* + RESULT( 16 ) = DQRT17( TRANS, 1, M, N, + $ NRHS, COPYA, LDA, B, LDB, + $ COPYB, LDB, C, WORK, + $ LWORK ) + ELSE +* +* Solving overdetermined system +* + RESULT( 16 ) = DQRT14( TRANS, M, N, + $ NRHS, COPYA, LDA, B, LDB, + $ WORK, LWORK ) + END IF +* +* Print information about the tests that +* did not pass the threshold. +* + DO 50 K = 15, 16 + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9997 )TRANS, M, + $ N, NRHS, MB, NB, ITYPE, K, + $ RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 50 CONTINUE + NRUN = NRUN + 2 + 60 CONTINUE + 62 CONTINUE + 65 CONTINUE END IF * * Generate a matrix of scaling type ISCALE and rank @@ -628,7 +739,7 @@ * Print information about the tests that did not * pass the threshold. * - DO 90 K = 3, NTESTS + DO 90 K = 3, 14 IF( RESULT( K ).GE.THRESH ) THEN IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) $ CALL ALAHD( NOUT, PATH ) @@ -637,7 +748,7 @@ NFAIL = NFAIL + 1 END IF 90 CONTINUE - NRUN = NRUN + 12 + NRUN = NRUN + 12 * 100 CONTINUE 110 CONTINUE @@ -654,6 +765,9 @@ $ ', NB=', I4, ', type', I2, ', test(', I2, ')=', G12.5 ) 9998 FORMAT( ' M=', I5, ', N=', I5, ', NRHS=', I4, ', NB=', I4, $ ', type', I2, ', test(', I2, ')=', G12.5 ) + 9997 FORMAT( ' TRANS=''', A1,' M=', I5, ', N=', I5, ', NRHS=', I4, + $ ', MB=', I4,', NB=', I4,', type', I2, + $ ', test(', I2, ')=', G12.5 ) RETURN * * End of DDRVLS diff --git a/TESTING/LIN/derrlqt.f b/TESTING/LIN/derrlqt.f new file mode 100644 index 00000000..5a768f01 --- /dev/null +++ b/TESTING/LIN/derrlqt.f @@ -0,0 +1,197 @@ +*> \brief \b DERLQT +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DERRLQT( PATH, NUNIT ) +* +* .. Scalar Arguments .. +* CHARACTER*3 PATH +* INTEGER NUNIT +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DERRLQT tests the error exits for the DOUBLE PRECISION routines +*> that use the LQT decomposition of a general matrix. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] PATH +*> \verbatim +*> PATH is CHARACTER*3 +*> The LAPACK path name for the routines to be tested. +*> \endverbatim +*> +*> \param[in] NUNIT +*> \verbatim +*> NUNIT is INTEGER +*> The unit number for output. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2011 +* +*> \ingroup double_lin +* +* ===================================================================== + SUBROUTINE DERRLQT( PATH, NUNIT ) + IMPLICIT NONE +* +* -- LAPACK test routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + CHARACTER*3 PATH + INTEGER NUNIT +* .. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER NMAX + PARAMETER ( NMAX = 2 ) +* .. +* .. Local Scalars .. + INTEGER I, INFO, J +* .. +* .. Local Arrays .. + DOUBLE PRECISION A( NMAX, NMAX ), T( NMAX, NMAX ), W( NMAX ), + $ C( NMAX, NMAX ) +* .. +* .. External Subroutines .. + EXTERNAL ALAESM, CHKXER, DGELQT3, DGELQT, + $ DGEMLQT +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, NOUT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NOUT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE +* .. +* .. Executable Statements .. +* + NOUT = NUNIT + WRITE( NOUT, FMT = * ) +* +* Set the variables to innocuous values. +* + DO J = 1, NMAX + DO I = 1, NMAX + A( I, J ) = 1.D0 / DBLE( I+J ) + C( I, J ) = 1.D0 / DBLE( I+J ) + T( I, J ) = 1.D0 / DBLE( I+J ) + END DO + W( J ) = 0.D0 + END DO + OK = .TRUE. +* +* Error exits for LQT factorization +* +* DGELQT +* + SRNAMT = 'DGELQT' + INFOT = 1 + CALL DGELQT( -1, 0, 1, A, 1, T, 1, W, INFO ) + CALL CHKXER( 'DGELQT', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DGELQT( 0, -1, 1, A, 1, T, 1, W, INFO ) + CALL CHKXER( 'DGELQT', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DGELQT( 0, 0, 0, A, 1, T, 1, W, INFO ) + CALL CHKXER( 'DGELQT', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL DGELQT( 2, 1, 1, A, 1, T, 1, W, INFO ) + CALL CHKXER( 'DGELQT', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL DGELQT( 2, 2, 2, A, 2, T, 1, W, INFO ) + CALL CHKXER( 'DGELQT', INFOT, NOUT, LERR, OK ) +* +* DGELQT3 +* + SRNAMT = 'DGELQT3' + INFOT = 1 + CALL DGELQT3( -1, 0, A, 1, T, 1, INFO ) + CALL CHKXER( 'DGELQT3', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DGELQT3( 0, -1, A, 1, T, 1, INFO ) + CALL CHKXER( 'DGELQT3', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DGELQT3( 2, 2, A, 1, T, 1, INFO ) + CALL CHKXER( 'DGELQT3', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL DGELQT3( 2, 2, A, 2, T, 1, INFO ) + CALL CHKXER( 'DGELQT3', INFOT, NOUT, LERR, OK ) +* +* DGEMLQT +* + SRNAMT = 'DGEMLQT' + INFOT = 1 + CALL DGEMLQT( '/', 'N', 0, 0, 0, 1, A, 1, T, 1, C, 1, W, INFO ) + CALL CHKXER( 'DGEMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DGEMLQT( 'L', '/', 0, 0, 0, 1, A, 1, T, 1, C, 1, W, INFO ) + CALL CHKXER( 'DGEMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DGEMLQT( 'L', 'N', -1, 0, 0, 1, A, 1, T, 1, C, 1, W, INFO ) + CALL CHKXER( 'DGEMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DGEMLQT( 'L', 'N', 0, -1, 0, 1, A, 1, T, 1, C, 1, W, INFO ) + CALL CHKXER( 'DGEMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL DGEMLQT( 'L', 'N', 0, 0, -1, 1, A, 1, T, 1, C, 1, W, INFO ) + CALL CHKXER( 'DGEMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL DGEMLQT( 'R', 'N', 0, 0, -1, 1, A, 1, T, 1, C, 1, W, INFO ) + CALL CHKXER( 'DGEMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL DGEMLQT( 'L', 'N', 0, 0, 0, 0, A, 1, T, 1, C, 1, W, INFO ) + CALL CHKXER( 'DGEMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL DGEMLQT( 'R', 'N', 2, 2, 2, 1, A, 1, T, 1, C, 1, W, INFO ) + CALL CHKXER( 'DGEMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL DGEMLQT( 'L', 'N', 2, 2, 2, 1, A, 1, T, 1, C, 1, W, INFO ) + CALL CHKXER( 'DGEMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL DGEMLQT( 'R', 'N', 1, 1, 1, 1, A, 1, T, 0, C, 1, W, INFO ) + CALL CHKXER( 'DGEMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 12 + CALL DGEMLQT( 'L', 'N', 1, 1, 1, 1, A, 1, T, 1, C, 0, W, INFO ) + CALL CHKXER( 'DGEMLQT', INFOT, NOUT, LERR, OK ) +* +* Print a summary line. +* + CALL ALAESM( PATH, OK, NOUT ) +* + RETURN +* +* End of DERRLQT +* + END diff --git a/TESTING/LIN/derrlqtp.f b/TESTING/LIN/derrlqtp.f new file mode 100644 index 00000000..ae118af9 --- /dev/null +++ b/TESTING/LIN/derrlqtp.f @@ -0,0 +1,225 @@ +*> \brief \b DERRLQTP +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DERRLQTP( PATH, NUNIT ) +* +* .. Scalar Arguments .. +* CHARACTER*3 PATH +* INTEGER NUNIT +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DERRLQTP tests the error exits for the REAL routines +*> that use the LQT decomposition of a triangular-pentagonal matrix. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] PATH +*> \verbatim +*> PATH is CHARACTER*3 +*> The LAPACK path name for the routines to be tested. +*> \endverbatim +*> +*> \param[in] NUNIT +*> \verbatim +*> NUNIT is INTEGER +*> The unit number for output. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2011 +* +*> \ingroup double_lin +* +* ===================================================================== + SUBROUTINE DERRLQTP( PATH, NUNIT ) + IMPLICIT NONE +* +* -- LAPACK test routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + CHARACTER*3 PATH + INTEGER NUNIT +* .. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER NMAX + PARAMETER ( NMAX = 2 ) +* .. +* .. Local Scalars .. + INTEGER I, INFO, J +* .. +* .. Local Arrays .. + DOUBLE PRECISION A( NMAX, NMAX ), T( NMAX, NMAX ), W( NMAX ), + $ B( NMAX, NMAX ), C( NMAX, NMAX ) +* .. +* .. External Subroutines .. + EXTERNAL ALAESM, CHKXER, DTPLQT2, DTPLQT, + $ DTPMLQT +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, NOUT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NOUT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE +* .. +* .. Executable Statements .. +* + NOUT = NUNIT + WRITE( NOUT, FMT = * ) +* +* Set the variables to innocuous values. +* + DO J = 1, NMAX + DO I = 1, NMAX + A( I, J ) = 1.D0 / DBLE( I+J ) + C( I, J ) = 1.D0 / DBLE( I+J ) + T( I, J ) = 1.D0 / DBLE( I+J ) + END DO + W( J ) = 0.0 + END DO + OK = .TRUE. +* +* Error exits for TPLQT factorization +* +* DTPLQT +* + SRNAMT = 'DTPLQT' + INFOT = 1 + CALL DTPLQT( -1, 1, 0, 1, A, 1, B, 1, T, 1, W, INFO ) + CALL CHKXER( 'DTPLQT', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DTPLQT( 1, -1, 0, 1, A, 1, B, 1, T, 1, W, INFO ) + CALL CHKXER( 'DTPLQT', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DTPLQT( 0, 1, -1, 1, A, 1, B, 1, T, 1, W, INFO ) + CALL CHKXER( 'DTPLQT', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DTPLQT( 0, 1, 1, 1, A, 1, B, 1, T, 1, W, INFO ) + CALL CHKXER( 'DTPLQT', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DTPLQT( 0, 1, 0, 0, A, 1, B, 1, T, 1, W, INFO ) + CALL CHKXER( 'DTPLQT', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DTPLQT( 1, 1, 0, 2, A, 1, B, 1, T, 1, W, INFO ) + CALL CHKXER( 'DTPLQT', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL DTPLQT( 2, 1, 0, 2, A, 1, B, 1, T, 1, W, INFO ) + CALL CHKXER( 'DTPLQT', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL DTPLQT( 2, 1, 0, 1, A, 2, B, 1, T, 1, W, INFO ) + CALL CHKXER( 'DTPLQT', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL DTPLQT( 2, 2, 1, 2, A, 2, B, 2, T, 1, W, INFO ) + CALL CHKXER( 'DTPLQT', INFOT, NOUT, LERR, OK ) +* +* DTPLQT2 +* + SRNAMT = 'DTPLQT2' + INFOT = 1 + CALL DTPLQT2( -1, 0, 0, A, 1, B, 1, T, 1, INFO ) + CALL CHKXER( 'DTPLQT2', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DTPLQT2( 0, -1, 0, A, 1, B, 1, T, 1, INFO ) + CALL CHKXER( 'DTPLQT2', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DTPLQT2( 0, 0, -1, A, 1, B, 1, T, 1, INFO ) + CALL CHKXER( 'DTPLQT2', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL DTPLQT2( 2, 2, 0, A, 1, B, 2, T, 2, INFO ) + CALL CHKXER( 'DTPLQT2', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL DTPLQT2( 2, 2, 0, A, 2, B, 1, T, 2, INFO ) + CALL CHKXER( 'DTPLQT2', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL DTPLQT2( 2, 2, 0, A, 2, B, 2, T, 1, INFO ) + CALL CHKXER( 'DTPLQT2', INFOT, NOUT, LERR, OK ) +* +* DTPMLQT +* + SRNAMT = 'DTPMLQT' + INFOT = 1 + CALL DTPMLQT( '/', 'N', 0, 0, 0, 0, 1, A, 1, T, 1, B, 1, C, 1, + $ W, INFO ) + CALL CHKXER( 'DTPMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DTPMLQT( 'L', '/', 0, 0, 0, 0, 1, A, 1, T, 1, B, 1, C, 1, + $ W, INFO ) + CALL CHKXER( 'DTPMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DTPMLQT( 'L', 'N', -1, 0, 0, 0, 1, A, 1, T, 1, B, 1, C, 1, + $ W, INFO ) + CALL CHKXER( 'DTPMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DTPMLQT( 'L', 'N', 0, -1, 0, 0, 1, A, 1, T, 1, B, 1, C, 1, + $ W, INFO ) + CALL CHKXER( 'DTPMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL DTPMLQT( 'L', 'N', 0, 0, -1, 0, 1, A, 1, T, 1, B, 1, C, 1, + $ W, INFO ) + INFOT = 6 + CALL DTPMLQT( 'L', 'N', 0, 0, 0, -1, 1, A, 1, T, 1, B, 1, C, 1, + $ W, INFO ) + CALL CHKXER( 'DTPMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL DTPMLQT( 'L', 'N', 0, 0, 0, 0, 0, A, 1, T, 1, B, 1, C, 1, + $ W, INFO ) + CALL CHKXER( 'DTPMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL DTPMLQT( 'R', 'N', 2, 2, 2, 1, 1, A, 1, T, 1, B, 1, C, 1, + $ W, INFO ) + CALL CHKXER( 'DTPMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL DTPMLQT( 'R', 'N', 1, 1, 1, 1, 1, A, 1, T, 0, B, 1, C, 1, + $ W, INFO ) + CALL CHKXER( 'DTPMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 13 + CALL DTPMLQT( 'L', 'N', 1, 1, 1, 1, 1, A, 1, T, 1, B, 0, C, 1, + $ W, INFO ) + CALL CHKXER( 'DTPMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 15 + CALL DTPMLQT( 'L', 'N', 1, 1, 1, 1, 1, A, 1, T, 1, B, 1, C, 0, + $ W, INFO ) + CALL CHKXER( 'DTPMLQT', INFOT, NOUT, LERR, OK ) +* +* Print a summary line. +* + CALL ALAESM( PATH, OK, NOUT ) +* + RETURN +* +* End of DERRLQT +* + END diff --git a/TESTING/LIN/derrtsqr.f b/TESTING/LIN/derrtsqr.f new file mode 100644 index 00000000..aa9f3674 --- /dev/null +++ b/TESTING/LIN/derrtsqr.f @@ -0,0 +1,243 @@ +*> \brief \b DERRTSQR +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DERRTSQR( PATH, NUNIT ) +* +* .. Scalar Arguments .. +* CHARACTER*3 PATH +* INTEGER NUNIT +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DERRTSQR tests the error exits for the DOUBLE PRECISION routines +*> that use the TSQR decomposition of a general matrix. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] PATH +*> \verbatim +*> PATH is CHARACTER*3 +*> The LAPACK path name for the routines to be tested. +*> \endverbatim +*> +*> \param[in] NUNIT +*> \verbatim +*> NUNIT is INTEGER +*> The unit number for output. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2011 +* +*> \ingroup double_lin +* +* ===================================================================== + SUBROUTINE DERRTSQR( PATH, NUNIT ) + IMPLICIT NONE +* +* -- LAPACK test routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + CHARACTER*3 PATH + INTEGER NUNIT +* .. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER NMAX + PARAMETER ( NMAX = 2 ) +* .. +* .. Local Scalars .. + INTEGER I, INFO, J, NB +* .. +* .. Local Arrays .. + DOUBLE PRECISION A( NMAX, NMAX ), T( NMAX, NMAX ), W( NMAX ), + $ C( NMAX, NMAX ), TAU(NMAX) +* .. +* .. External Subroutines .. + EXTERNAL ALAESM, CHKXER, DGEQR, + $ DGEMQR, DGELQ, DGEMLQ +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, NOUT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NOUT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE +* .. +* .. Executable Statements .. +* + NOUT = NUNIT + WRITE( NOUT, FMT = * ) +* +* Set the variables to innocuous values. +* + DO J = 1, NMAX + DO I = 1, NMAX + A( I, J ) = 1.D0 / DBLE( I+J ) + C( I, J ) = 1.D0 / DBLE( I+J ) + T( I, J ) = 1.D0 / DBLE( I+J ) + END DO + W( J ) = 0.D0 + END DO + OK = .TRUE. +* +* Error exits for TS factorization +* +* DGEQR +* + SRNAMT = 'DGEQR' + INFOT = 1 + CALL DGEQR( -1, 0, A, 1, TAU, 1, W, 1, INFO ) + CALL CHKXER( 'DGEQR', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DGEQR( 0, -1, A, 1, TAU, 1, W, 1, INFO ) + CALL CHKXER( 'DGEQR', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DGEQR( 1, 1, A, 0, TAU, 1, W, 1, INFO ) + CALL CHKXER( 'DGEQR', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL DGEQR( 3, 2, A, 3, TAU, 1, W, 1, INFO ) + CALL CHKXER( 'DGEQR', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL DGEQR( 3, 2, A, 3, TAU, 7, W, 0, INFO ) + CALL CHKXER( 'DGEQR', INFOT, NOUT, LERR, OK ) +* +* DGEMQR +* + TAU(1)=1 + TAU(2)=1 + SRNAMT = 'DGEMQR' + NB=1 + INFOT = 1 + CALL DGEMQR( '/', 'N', 0, 0, 0, A, 1, TAU, 1, C, 1, W, 1,INFO) + CALL CHKXER( 'DGEMQR', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DGEMQR( 'L', '/', 0, 0, 0, A, 1, TAU, 1, C, 1, W, 1,INFO) + CALL CHKXER( 'DGEMQR', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DGEMQR( 'L', 'N', -1, 0, 0, A, 1, TAU, 1, C, 1, W,1,INFO) + CALL CHKXER( 'DGEMQR', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DGEMQR( 'L', 'N', 0, -1, 0, A, 1, TAU, 1, C, 1, W,1,INFO) + CALL CHKXER( 'DGEMQR', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL DGEMQR( 'L', 'N', 0, 0, -1, A, 1, TAU, 1, C, 1, W,1,INFO) + CALL CHKXER( 'DGEMQR', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL DGEMQR( 'R', 'N', 0, 0, -1, A, 1, TAU, 1, C, 1, W,1,INFO) + CALL CHKXER( 'DGEMQR', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL DGEMQR( 'L', 'N', 2, 1, 0, A, 0, TAU, 1, C, 1, W, 1,INFO) + CALL CHKXER( 'DGEMQR', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL DGEMQR( 'R', 'N', 2, 2, 1, A, 1, TAU, 0, C, 1, W, 1,INFO) + CALL CHKXER( 'DGEMQR', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL DGEMQR( 'L', 'N', 2, 2, 1, A, 1, TAU, 0, C, 1, W, 1,INFO) + CALL CHKXER( 'DGEMQR', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL DGEMQR( 'L', 'N', 2, 1, 1, A, 1, TAU, 6, C, 0, W, 1,INFO) + CALL CHKXER( 'DGEMQR', INFOT, NOUT, LERR, OK ) + INFOT = 13 + CALL DGEMQR( 'L', 'N', 2, 2, 1, A, 2, TAU, 6, C, 2, W, 0,INFO) + CALL CHKXER( 'DGEMQR', INFOT, NOUT, LERR, OK ) +* +* DGELQ +* + SRNAMT = 'DGELQ' + INFOT = 1 + CALL DGELQ( -1, 0, A, 1, TAU, 1, W, 1, INFO ) + CALL CHKXER( 'DGELQ', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DGELQ( 0, -1, A, 1, TAU, 1, W, 1, INFO ) + CALL CHKXER( 'DGELQ', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DGELQ( 1, 1, A, 0, TAU, 1, W, 1, INFO ) + CALL CHKXER( 'DGELQ', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL DGELQ( 2, 3, A, 3, TAU, 1, W, 1, INFO ) + CALL CHKXER( 'DGELQ', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL DGELQ( 2, 3, A, 3, TAU, 7, W, 0, INFO ) + CALL CHKXER( 'DGELQ', INFOT, NOUT, LERR, OK ) +* +* DGEMLQ +* + TAU(1)=1 + TAU(2)=1 + SRNAMT = 'DGEMLQ' + NB=1 + INFOT = 1 + CALL DGEMLQ( '/', 'N', 0, 0, 0, A, 1, TAU, 1, C, 1, W, 1,INFO) + CALL CHKXER( 'DGEMLQ', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DGEMLQ( 'L', '/', 0, 0, 0, A, 1, TAU, 1, C, 1, W, 1,INFO) + CALL CHKXER( 'DGEMLQ', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DGEMLQ( 'L', 'N', -1, 0, 0, A, 1, TAU, 1, C, 1, W,1,INFO) + CALL CHKXER( 'DGEMLQ', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DGEMLQ( 'L', 'N', 0, -1, 0, A, 1, TAU, 1, C, 1, W,1,INFO) + CALL CHKXER( 'DGEMLQ', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL DGEMLQ( 'L', 'N', 0, 0, -1, A, 1, TAU, 1, C, 1, W,1,INFO) + CALL CHKXER( 'DGEMLQ', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL DGEMLQ( 'R', 'N', 0, 0, -1, A, 1, TAU, 1, C, 1, W,1,INFO) + CALL CHKXER( 'DGEMLQ', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL DGEMLQ( 'L', 'N', 1, 2, 0, A, 0, TAU, 1, C, 1, W, 1,INFO) + CALL CHKXER( 'DGEMLQ', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL DGEMLQ( 'R', 'N', 2, 2, 1, A, 1, TAU, 0, C, 1, W, 1,INFO) + CALL CHKXER( 'DGEMLQ', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL DGEMLQ( 'L', 'N', 2, 2, 1, A, 1, TAU, 0, C, 1, W, 1,INFO) + CALL CHKXER( 'DGEMLQ', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL DGEMLQ( 'L', 'N', 1, 2, 1, A, 1, TAU, 6, C, 0, W, 1,INFO) + CALL CHKXER( 'DGEMLQ', INFOT, NOUT, LERR, OK ) + INFOT = 13 + CALL DGEMLQ( 'L', 'N', 2, 2, 1, A, 2, TAU, 6, C, 2, W, 0,INFO) + CALL CHKXER( 'DGEMLQ', INFOT, NOUT, LERR, OK ) +* +* Print a summary line. +* + CALL ALAESM( PATH, OK, NOUT ) +* + RETURN +* +* End of DERRTSQR +* + END diff --git a/TESTING/LIN/dlqt04.f b/TESTING/LIN/dlqt04.f new file mode 100644 index 00000000..216ef3ea --- /dev/null +++ b/TESTING/LIN/dlqt04.f @@ -0,0 +1,259 @@ +*> \brief \b DLQT04 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DLQT04(M,N,NB,RESULT) +* +* .. Scalar Arguments .. +* INTEGER M, N, NB, LDT +* .. Return values .. +* DOUBLE PRECISION RESULT(6) +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLQT04 tests DGELQT and DGEMLQT. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> Number of rows in test matrix. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> Number of columns in test matrix. +*> \endverbatim +*> +*> \param[in] NB +*> \verbatim +*> NB is INTEGER +*> Block size of test matrix. NB <= Min(M,N). +*> \endverbatim +*> +*> \param[out] RESULT +*> \verbatim +*> RESULT is DOUBLE PRECISION array, dimension (6) +*> Results of each of the six tests below. +*> +*> RESULT(1) = | A - L Q | +*> RESULT(2) = | I - Q Q^H | +*> RESULT(3) = | Q C - Q C | +*> RESULT(4) = | Q^H C - Q^H C | +*> RESULT(5) = | C Q - C Q | +*> RESULT(6) = | C Q^H - C Q^H | +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date April 2012 +* +*> \ingroup double_lin +* +* ===================================================================== + SUBROUTINE DLQT04(M,N,NB,RESULT) + IMPLICIT NONE +* +* -- LAPACK test routine (version 3.4.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* April 2012 +* +* .. Scalar Arguments .. + INTEGER M, N, NB, LDT +* .. Return values .. + DOUBLE PRECISION RESULT(6) +* +* ===================================================================== +* +* .. +* .. Local allocatable arrays + DOUBLE PRECISION, ALLOCATABLE :: AF(:,:), Q(:,:), + $ L(:,:), RWORK(:), WORK( : ), T(:,:), + $ CF(:,:), DF(:,:), A(:,:), C(:,:), D(:,:) +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER( ZERO = 0.0, ONE = 1.0 ) +* .. +* .. Local Scalars .. + INTEGER INFO, J, K, LL, LWORK + DOUBLE PRECISION ANORM, EPS, RESID, CNORM, DNORM +* .. +* .. Local Arrays .. + INTEGER ISEED( 4 ) +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH, DLANGE, DLANSY + LOGICAL LSAME + EXTERNAL DLAMCH, DLANGE, DLANSY, LSAME +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Data statements .. + DATA ISEED / 1988, 1989, 1990, 1991 / +* + EPS = DLAMCH( 'Epsilon' ) + K = MIN(M,N) + LL = MAX(M,N) + LWORK = MAX(2,LL)*MAX(2,LL)*NB +* +* Dynamically allocate local arrays +* + ALLOCATE ( A(M,N), AF(M,N), Q(N,N), L(LL,N), RWORK(LL), + $ WORK(LWORK), T(NB,N), C(M,N), CF(M,N), + $ D(N,M), DF(N,M) ) +* +* Put random numbers into A and copy to AF +* + LDT=NB + DO J=1,N + CALL DLARNV( 2, ISEED, M, A( 1, J ) ) + END DO + CALL DLACPY( 'Full', M, N, A, M, AF, M ) +* +* Factor the matrix A in the array AF. +* + CALL DGELQT( M, N, NB, AF, M, T, LDT, WORK, INFO ) +* +* Generate the n-by-n matrix Q +* + CALL DLASET( 'Full', N, N, ZERO, ONE, Q, N ) + CALL DGEMLQT( 'R', 'N', N, N, K, NB, AF, M, T, LDT, Q, N, + $ WORK, INFO ) +* +* Copy R +* + CALL DLASET( 'Full', M, N, ZERO, ZERO, L, LL ) + CALL DLACPY( 'Lower', M, N, AF, M, L, LL ) +* +* Compute |L - A*Q'| / |A| and store in RESULT(1) +* + CALL DGEMM( 'N', 'T', M, N, N, -ONE, A, M, Q, N, ONE, L, LL ) + ANORM = DLANGE( '1', M, N, A, M, RWORK ) + RESID = DLANGE( '1', M, N, L, LL, RWORK ) + IF( ANORM.GT.ZERO ) THEN + RESULT( 1 ) = RESID / (EPS*MAX(1,M)*ANORM) + ELSE + RESULT( 1 ) = ZERO + END IF +* +* Compute |I - Q'*Q| and store in RESULT(2) +* + CALL DLASET( 'Full', N, N, ZERO, ONE, L, LL ) + CALL DSYRK( 'U', 'C', N, N, -ONE, Q, N, ONE, L, LL ) + RESID = DLANSY( '1', 'Upper', N, L, LL, RWORK ) + RESULT( 2 ) = RESID / (EPS*MAX(1,N)) +* +* Generate random m-by-n matrix C and a copy CF +* + DO J=1,M + CALL DLARNV( 2, ISEED, N, D( 1, J ) ) + END DO + DNORM = DLANGE( '1', N, M, D, N, RWORK) + CALL DLACPY( 'Full', N, M, D, N, DF, N ) +* +* Apply Q to C as Q*C +* + CALL DGEMLQT( 'L', 'N', N, M, K, NB, AF, M, T, NB, DF, N, + $ WORK, INFO) +* +* Compute |Q*D - Q*D| / |D| +* + CALL DGEMM( 'N', 'N', N, M, N, -ONE, Q, N, D, N, ONE, DF, N ) + RESID = DLANGE( '1', N, M, DF, N, RWORK ) + IF( DNORM.GT.ZERO ) THEN + RESULT( 3 ) = RESID / (EPS*MAX(1,M)*DNORM) + ELSE + RESULT( 3 ) = ZERO + END IF +* +* Copy D into DF again +* + CALL DLACPY( 'Full', N, M, D, N, DF, N ) +* +* Apply Q to D as QT*D +* + CALL DGEMLQT( 'L', 'T', N, M, K, NB, AF, M, T, NB, DF, N, + $ WORK, INFO) +* +* Compute |QT*D - QT*D| / |D| +* + CALL DGEMM( 'T', 'N', N, M, N, -ONE, Q, N, D, N, ONE, DF, N ) + RESID = DLANGE( '1', N, M, DF, N, RWORK ) + IF( DNORM.GT.ZERO ) THEN + RESULT( 4 ) = RESID / (EPS*MAX(1,M)*DNORM) + ELSE + RESULT( 4 ) = ZERO + END IF +* +* Generate random n-by-m matrix D and a copy DF +* + DO J=1,N + CALL DLARNV( 2, ISEED, M, C( 1, J ) ) + END DO + CNORM = DLANGE( '1', M, N, C, M, RWORK) + CALL DLACPY( 'Full', M, N, C, M, CF, M ) +* +* Apply Q to C as C*Q +* + CALL DGEMLQT( 'R', 'N', M, N, K, NB, AF, M, T, NB, CF, M, + $ WORK, INFO) +* +* Compute |C*Q - C*Q| / |C| +* + CALL DGEMM( 'N', 'N', M, N, N, -ONE, C, M, Q, N, ONE, CF, M ) + RESID = DLANGE( '1', N, M, DF, N, RWORK ) + IF( CNORM.GT.ZERO ) THEN + RESULT( 5 ) = RESID / (EPS*MAX(1,M)*DNORM) + ELSE + RESULT( 5 ) = ZERO + END IF +* +* Copy C into CF again +* + CALL DLACPY( 'Full', M, N, C, M, CF, M ) +* +* Apply Q to D as D*QT +* + CALL DGEMLQT( 'R', 'T', M, N, K, NB, AF, M, T, NB, CF, M, + $ WORK, INFO) +* +* Compute |C*QT - C*QT| / |C| +* + CALL DGEMM( 'N', 'T', M, N, N, -ONE, C, M, Q, N, ONE, CF, M ) + RESID = DLANGE( '1', M, N, CF, M, RWORK ) + IF( CNORM.GT.ZERO ) THEN + RESULT( 6 ) = RESID / (EPS*MAX(1,M)*DNORM) + ELSE + RESULT( 6 ) = ZERO + END IF +* +* Deallocate all arrays +* + DEALLOCATE ( A, AF, Q, L, RWORK, WORK, T, C, D, CF, DF) +* + RETURN + END + diff --git a/TESTING/LIN/dlqt05.f b/TESTING/LIN/dlqt05.f new file mode 100644 index 00000000..b357dcb5 --- /dev/null +++ b/TESTING/LIN/dlqt05.f @@ -0,0 +1,286 @@ +*> \brief \b DLQT05 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DLQT05(M,N,L,NB,RESULT) +* +* .. Scalar Arguments .. +* INTEGER LWORK, M, N, L, NB, LDT +* .. Return values .. +* DOUBLE PRECISION RESULT(6) +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DQRT05 tests DTPLQT and DTPMLQT. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> Number of rows in lower part of the test matrix. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> Number of columns in test matrix. +*> \endverbatim +*> +*> \param[in] L +*> \verbatim +*> L is INTEGER +*> The number of rows of the upper trapezoidal part the +*> lower test matrix. 0 <= L <= M. +*> \endverbatim +*> +*> \param[in] NB +*> \verbatim +*> NB is INTEGER +*> Block size of test matrix. NB <= N. +*> \endverbatim +*> +*> \param[out] RESULT +*> \verbatim +*> RESULT is DOUBLE PRECISION array, dimension (6) +*> Results of each of the six tests below. +*> +*> RESULT(1) = | A - Q R | +*> RESULT(2) = | I - Q^H Q | +*> RESULT(3) = | Q C - Q C | +*> RESULT(4) = | Q^H C - Q^H C | +*> RESULT(5) = | C Q - C Q | +*> RESULT(6) = | C Q^H - C Q^H | +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date April 2012 +* +*> \ingroup double_lin +* +* ===================================================================== + SUBROUTINE DLQT05(M,N,L,NB,RESULT) + IMPLICIT NONE +* +* -- LAPACK test routine (version 3.4.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* April 2012 +* +* .. Scalar Arguments .. + INTEGER LWORK, M, N, L, NB, LDT +* .. Return values .. + DOUBLE PRECISION RESULT(6) +* +* ===================================================================== +* +* .. +* .. Local allocatable arrays + DOUBLE PRECISION, ALLOCATABLE :: AF(:,:), Q(:,:), + $ R(:,:), RWORK(:), WORK( : ), T(:,:), + $ CF(:,:), DF(:,:), A(:,:), C(:,:), D(:,:) +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER( ZERO = 0.0, ONE = 1.0 ) +* .. +* .. Local Scalars .. + INTEGER INFO, J, K, N2, NP1,i + DOUBLE PRECISION ANORM, EPS, RESID, CNORM, DNORM +* .. +* .. Local Arrays .. + INTEGER ISEED( 4 ) +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH, DLANGE, DLANSY + LOGICAL LSAME + EXTERNAL DLAMCH, DLANGE, DLANSY, LSAME +* .. +* .. Data statements .. + DATA ISEED / 1988, 1989, 1990, 1991 / +* + EPS = DLAMCH( 'Epsilon' ) + K = M + N2 = M+N + IF( N.GT.0 ) THEN + NP1 = M+1 + ELSE + NP1 = 1 + END IF + LWORK = N2*N2*NB +* +* Dynamically allocate all arrays +* + ALLOCATE(A(M,N2),AF(M,N2),Q(N2,N2),R(N2,N2),RWORK(N2), + $ WORK(LWORK),T(NB,M),C(N2,M),CF(N2,M), + $ D(M,N2),DF(M,N2) ) +* +* Put random stuff into A +* + LDT=NB + CALL DLASET( 'Full', M, N2, ZERO, ZERO, A, M ) + CALL DLASET( 'Full', NB, M, ZERO, ZERO, T, NB ) + DO J=1,M + CALL DLARNV( 2, ISEED, M-J+1, A( J, J ) ) + END DO + IF( N.GT.0 ) THEN + DO J=1,N-L + CALL DLARNV( 2, ISEED, M, A( 1, MIN(N+M,M+1) + J - 1 ) ) + END DO + END IF + IF( L.GT.0 ) THEN + DO J=1,L + CALL DLARNV( 2, ISEED, M-J+1, A( J, MIN(N+M,N+M-L+1) + $ + J - 1 ) ) + END DO + END IF +* +* Copy the matrix A to the array AF. +* + CALL DLACPY( 'Full', M, N2, A, M, AF, M ) +* +* Factor the matrix A in the array AF. +* + CALL DTPLQT( M,N,L,NB,AF,M,AF(1,NP1),M,T,LDT,WORK,INFO) +* +* Generate the (M+N)-by-(M+N) matrix Q by applying H to I +* + CALL DLASET( 'Full', N2, N2, ZERO, ONE, Q, N2 ) + CALL DGEMLQT( 'L', 'N', N2, N2, K, NB, AF, M, T, LDT, Q, N2, + $ WORK, INFO ) +* +* Copy L +* + CALL DLASET( 'Full', N2, N2, ZERO, ZERO, R, N2 ) + CALL DLACPY( 'Lower', M, N2, AF, M, R, N2 ) +* +* Compute |L - A*Q*T| / |A| and store in RESULT(1) +* + CALL DGEMM( 'N', 'T', M, N2, N2, -ONE, A, M, Q, N2, ONE, R, N2) + ANORM = DLANGE( '1', M, N2, A, M, RWORK ) + RESID = DLANGE( '1', M, N2, R, N2, RWORK ) + IF( ANORM.GT.ZERO ) THEN + RESULT( 1 ) = RESID / (EPS*ANORM*MAX(1,N2)) + ELSE + RESULT( 1 ) = ZERO + END IF +* +* Compute |I - Q*Q'| and store in RESULT(2) +* + CALL DLASET( 'Full', N2, N2, ZERO, ONE, R, N2 ) + CALL DSYRK( 'U', 'N', N2, N2, -ONE, Q, N2, ONE, R, N2 ) + RESID = DLANSY( '1', 'Upper', N2, R, N2, RWORK ) + RESULT( 2 ) = RESID / (EPS*MAX(1,N2)) +* +* Generate random m-by-n matrix C and a copy CF +* + CALL DLASET( 'Full', N2, M, ZERO, ONE, C, N2 ) + DO J=1,M + CALL DLARNV( 2, ISEED, N2, C( 1, J ) ) + END DO + CNORM = DLANGE( '1', N2, M, C, N2, RWORK) + CALL DLACPY( 'Full', N2, M, C, N2, CF, N2 ) +* +* Apply Q to C as Q*C +* + CALL DTPMLQT( 'L','N', N,M,K,L,NB,AF(1, NP1),M,T,LDT,CF,N2, + $ CF(NP1,1),N2,WORK,INFO) +* +* Compute |Q*C - Q*C| / |C| +* + CALL DGEMM( 'N', 'N', N2, M, N2, -ONE, Q, N2, C, N2, ONE, CF, N2 ) + RESID = DLANGE( '1', N2, M, CF, N2, RWORK ) + IF( CNORM.GT.ZERO ) THEN + RESULT( 3 ) = RESID / (EPS*MAX(1,N2)*CNORM) + ELSE + RESULT( 3 ) = ZERO + END IF + +* +* Copy C into CF again +* + CALL DLACPY( 'Full', N2, M, C, N2, CF, N2 ) +* +* Apply Q to C as QT*C +* + CALL DTPMLQT( 'L','T',N,M,K,L,NB,AF(1,NP1),M,T,LDT,CF,N2, + $ CF(NP1,1),N2,WORK,INFO) +* +* Compute |QT*C - QT*C| / |C| +* + CALL DGEMM('T','N',N2,M,N2,-ONE,Q,N2,C,N2,ONE,CF,N2) + RESID = DLANGE( '1', N2, M, CF, N2, RWORK ) + + IF( CNORM.GT.ZERO ) THEN + RESULT( 4 ) = RESID / (EPS*MAX(1,N2)*CNORM) + ELSE + RESULT( 4 ) = ZERO + END IF +* +* Generate random m-by-n matrix D and a copy DF +* + DO J=1,N2 + CALL DLARNV( 2, ISEED, M, D( 1, J ) ) + END DO + DNORM = DLANGE( '1', M, N2, D, M, RWORK) + CALL DLACPY( 'Full', M, N2, D, M, DF, M ) +* +* Apply Q to D as D*Q +* + CALL DTPMLQT('R','N',M,N,K,L,NB,AF(1,NP1),M,T,LDT,DF,M, + $ DF(1,NP1),M,WORK,INFO) +* +* Compute |D*Q - D*Q| / |D| +* + CALL DGEMM('N','N',M,N2,N2,-ONE,D,M,Q,N2,ONE,DF,M) + RESID = DLANGE('1',M, N2,DF,M,RWORK ) + IF( CNORM.GT.ZERO ) THEN + RESULT( 5 ) = RESID / (EPS*MAX(1,N2)*DNORM) + ELSE + RESULT( 5 ) = ZERO + END IF +* +* Copy D into DF again +* + CALL DLACPY('Full',M,N2,D,M,DF,M ) +* +* Apply Q to D as D*QT +* + CALL DTPMLQT('R','T',M,N,K,L,NB,AF(1,NP1),M,T,LDT,DF,M, + $ DF(1,NP1),M,WORK,INFO) + +* +* Compute |D*QT - D*QT| / |D| +* + CALL DGEMM( 'N', 'T', M, N2, N2, -ONE, D, M, Q, N2, ONE, DF, M ) + RESID = DLANGE( '1', M, N2, DF, M, RWORK ) + IF( CNORM.GT.ZERO ) THEN + RESULT( 6 ) = RESID / (EPS*MAX(1,N2)*DNORM) + ELSE + RESULT( 6 ) = ZERO + END IF +* +* Deallocate all arrays +* + DEALLOCATE ( A, AF, Q, R, RWORK, WORK, T, C, D, CF, DF) + RETURN + END
\ No newline at end of file diff --git a/TESTING/LIN/dtplqt.f b/TESTING/LIN/dtplqt.f new file mode 100644 index 00000000..27965442 --- /dev/null +++ b/TESTING/LIN/dtplqt.f @@ -0,0 +1,270 @@ +*> \brief \b DTPLQT +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DTPQRT + dependencies +*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dtplqt.f"> +*> [TGZ]</a> +*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dtplqt.f"> +*> [ZIP]</a> +*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dtplqt.f"> +*> [TXT]</a> +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DTPLQT( M, N, L, MB, A, LDA, B, LDB, T, LDT, WORK, +* INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, LDB, LDT, N, M, L, MB +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), T( LDT, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DTPLQT computes a blocked LQ factorization of a real +*> "triangular-pentagonal" matrix C, which is composed of a +*> triangular block A and pentagonal block B, using the compact +*> WY representation for Q. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix B, and the order of the +*> triangular matrix A. +*> M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix B. +*> N >= 0. +*> \endverbatim +*> +*> \param[in] L +*> \verbatim +*> L is INTEGER +*> The number of rows of the lower trapezoidal part of B. +*> MIN(M,N) >= L >= 0. See Further Details. +*> \endverbatim +*> +*> \param[in] MB +*> \verbatim +*> MB is INTEGER +*> The block size to be used in the blocked QR. M >= MB >= 1. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the lower triangular N-by-N matrix A. +*> On exit, the elements on and below the diagonal of the array +*> contain the lower triangular matrix L. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,N) +*> On entry, the pentagonal M-by-N matrix B. The first N-L columns +*> are rectangular, and the last L columns are lower trapezoidal. +*> On exit, B contains the pentagonal matrix V. See Further Details. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,M). +*> \endverbatim +*> +*> \param[out] T +*> \verbatim +*> T is DOUBLE PRECISION array, dimension (LDT,N) +*> The lower triangular block reflectors stored in compact form +*> as a sequence of upper triangular blocks. See Further Details. +*> \endverbatim +*> +*> \param[in] LDT +*> \verbatim +*> LDT is INTEGER +*> The leading dimension of the array T. LDT >= MB. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MB*M) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2013 +* +*> \ingroup doubleOTHERcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The input matrix C is a M-by-(M+N) matrix +*> +*> C = [ A ] [ B ] +*> +*> +*> where A is an lower triangular N-by-N matrix, and B is M-by-N pentagonal +*> matrix consisting of a M-by-(N-L) rectangular matrix B1 on left of a M-by-L +*> upper trapezoidal matrix B2: +*> [ B ] = [ B1 ] [ B2 ] +*> [ B1 ] <- M-by-(N-L) rectangular +*> [ B2 ] <- M-by-L upper trapezoidal. +*> +*> The lower trapezoidal matrix B2 consists of the first L columns of a +*> N-by-N lower triangular matrix, where 0 <= L <= MIN(M,N). If L=0, +*> B is rectangular M-by-N; if M=L=N, B is lower triangular. +*> +*> The matrix W stores the elementary reflectors H(i) in the i-th row +*> above the diagonal (of A) in the M-by-(M+N) input matrix C +*> [ C ] = [ A ] [ B ] +*> [ A ] <- lower triangular N-by-N +*> [ B ] <- M-by-N pentagonal +*> +*> so that W can be represented as +*> [ W ] = [ I ] [ V ] +*> [ I ] <- identity, N-by-N +*> [ V ] <- M-by-N, same form as B. +*> +*> Thus, all of information needed for W is contained on exit in B, which +*> we call V above. Note that V has the same form as B; that is, +*> [ V ] = [ V1 ] [ V2 ] +*> [ V1 ] <- M-by-(N-L) rectangular +*> [ V2 ] <- M-by-L lower trapezoidal. +*> +*> The rows of V represent the vectors which define the H(i)'s. +*> +*> The number of blocks is B = ceiling(M/MB), where each +*> block is of order MB except for the last block, which is of order +*> IB = M - (M-1)*MB. For each of the B blocks, a upper triangular block +*> reflector factor is computed: T1, T2, ..., TB. The MB-by-MB (and IB-by-IB +*> for the last block) T's are stored in the MB-by-N matrix T as +*> +*> T = [T1 T2 ... TB]. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DTPLQT( M, N, L, MB, A, LDA, B, LDB, T, LDT, WORK, + $ INFO ) +* +* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2013 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, LDB, LDT, N, M, L, MB +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), T( LDT, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. +* .. Local Scalars .. + INTEGER I, IB, LB, NB, IINFO +* .. +* .. External Subroutines .. + EXTERNAL DTPLQT2, DTPRFB, XERBLA +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( L.LT.0 .OR. (L.GT.MIN(M,N) .AND. MIN(M,N).GE.0)) THEN + INFO = -3 + ELSE IF( MB.LT.1 .OR. (MB.GT.M .AND. M.GT.0)) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -6 + ELSE IF( LDB.LT.MAX( 1, M ) ) THEN + INFO = -8 + ELSE IF( LDT.LT.MB ) THEN + INFO = -10 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DTPLQT', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.0 .OR. N.EQ.0 ) RETURN +* + DO I = 1, M, MB +* +* Compute the QR factorization of the current block +* + IB = MIN( M-I+1, MB ) + NB = MIN( N-L+I+IB-1, N ) + IF( I.GE.L ) THEN + LB = 0 + ELSE + LB = NB-N+L-I+1 + END IF +* + CALL DTPLQT2( IB, NB, LB, A(I,I), LDA, B( I, 1 ), LDB, + $ T(1, I ), LDT, IINFO ) +* +* Update by applying H**T to B(I+IB:M,:) from the right +* + IF( I+IB.LE.M ) THEN + CALL DTPRFB( 'R', 'N', 'F', 'R', M-I-IB+1, NB, IB, LB, + $ B( I, 1 ), LDB, T( 1, I ), LDT, + $ A( I+IB, I ), LDA, B( I+IB, 1 ), LDB, + $ WORK, M-I-IB+1) + END IF + END DO + RETURN +* +* End of DTPLQT +* + END diff --git a/TESTING/LIN/dtsqr01.f b/TESTING/LIN/dtsqr01.f new file mode 100644 index 00000000..29d4b63e --- /dev/null +++ b/TESTING/LIN/dtsqr01.f @@ -0,0 +1,428 @@ +*> \brief \b DTSQR01 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DTSQR01(TSSW, M,N, MB, NB, RESULT) +* +* .. Scalar Arguments .. +* INTEGER M, N, MB +* .. Return values .. +* DOUBLE PRECISION RESULT(6) +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DTSQR01 tests DGEQR , DGELQ, DGEMLQ and DGEMQR. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] TSSW +*> \verbatim +*> TSSW is CHARACTER +*> 'TS' for testing tall skinny QR +*> and anything else for testing short wide LQ +*> \endverbatim +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> Number of rows in test matrix. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> Number of columns in test matrix. +*> \endverbatim +*> \param[in] MB +*> \verbatim +*> MB is INTEGER +*> Number of row in row block in test matrix. +*> \endverbatim +*> +*> \param[in] NB +*> \verbatim +*> NB is INTEGER +*> Number of columns in column block test matrix. +*> \endverbatim +*> +*> \param[out] RESULT +*> \verbatim +*> RESULT is DOUBLE PRECISION array, dimension (6) +*> Results of each of the six tests below. +*> +*> RESULT(1) = | A - Q R | or | A - L Q | +*> RESULT(2) = | I - Q^H Q | or | I - Q Q^H | +*> RESULT(3) = | Q C - Q C | +*> RESULT(4) = | Q^H C - Q^H C | +*> RESULT(5) = | C Q - C Q | +*> RESULT(6) = | C Q^H - C Q^H | +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date April 2012 +* +*> \ingroup double_lin +* +* ===================================================================== + SUBROUTINE DTSQR01(TSSW, M, N, MB, NB, RESULT) + IMPLICIT NONE +* +* -- LAPACK test routine (version 3.4.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* April 2012 +* +* .. Scalar Arguments .. + CHARACTER TSSW + INTEGER M, N, MB, NB +* .. Return values .. + DOUBLE PRECISION RESULT(6) +* +* ===================================================================== +* +* .. +* .. Local allocatable arrays + DOUBLE PRECISION, ALLOCATABLE :: AF(:,:), Q(:,:), + $ R(:,:), RWORK(:), WORK( : ), T(:), + $ CF(:,:), DF(:,:), A(:,:), C(:,:), D(:,:), LQ(:,:) +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER( ZERO = 0.0, ONE = 1.0 ) +* .. +* .. Local Scalars .. + LOGICAL TESTZEROS, TS + INTEGER INFO, J, K, L, LWORK, LT ,MNB + DOUBLE PRECISION ANORM, EPS, RESID, CNORM, DNORM +* .. +* .. Local Arrays .. + INTEGER ISEED( 4 ) +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH, DLANGE, DLANSY + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL DLAMCH, DLANGE, DLANSY, LSAME, ILAENV +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. Scalars in Common .. + CHARACTER*32 srnamt +* .. +* .. Common blocks .. + COMMON / srnamc / srnamt +* .. +* .. Data statements .. + DATA ISEED / 1988, 1989, 1990, 1991 / +* +* TEST TALL SKINNY OR SHORT WIDE +* + TS = LSAME(TSSW, 'TS') +* +* TEST MATRICES WITH HALF OF MATRIX BEING ZEROS +* + TESTZEROS = .FALSE. +* + EPS = DLAMCH( 'Epsilon' ) + K = MIN(M,N) + L = MAX(M,N,1) + MNB = MAX ( MB, NB) + LWORK = MAX(3,L)*MNB + IF((K.GE.MNB).OR.(MNB.GE.L))THEN + LT=MAX(1,L)*MNB+5 + ELSE + LT=MAX(1,(L-K)/(MNB-K)+1)*L*MNB+5 + END IF + +* +* Dynamically allocate local arrays +* + ALLOCATE ( A(M,N), AF(M,N), Q(L,L), R(M,L), RWORK(L), + $ WORK(LWORK), T(LT), C(M,N), CF(M,N), + $ D(N,M), DF(N,M), LQ(L,N) ) +* +* Put random numbers into A and copy to AF +* + DO J=1,N + CALL DLARNV( 2, ISEED, M, A( 1, J ) ) + END DO + IF (TESTZEROS) THEN + IF (M.GE.4) THEN + DO J=1,N + CALL DLARNV( 2, ISEED, M/2, A( M/4, J ) ) + END DO + END IF + END IF + CALL DLACPY( 'Full', M, N, A, M, AF, M ) +* + IF (TS) THEN +* +* Factor the matrix A in the array AF. +* + srnamt = 'DGEQR' + CALL DGEQR( M, N, AF, M, T, LT, WORK, LWORK, INFO ) +* +* Generate the m-by-m matrix Q +* + CALL DLASET( 'Full', M, M, ZERO, ONE, Q, M ) + srnamt = 'DGEMQR' + CALL DGEMQR( 'L', 'N', M, M, K, AF, M, T, LT, Q, M, + $ WORK, LWORK, INFO ) +* +* Copy R +* + CALL DLASET( 'Full', M, N, ZERO, ZERO, R, M ) + CALL DLACPY( 'Upper', M, N, AF, M, R, M ) +* +* Compute |R - Q'*A| / |A| and store in RESULT(1) +* + CALL DGEMM( 'T', 'N', M, N, M, -ONE, Q, M, A, M, ONE, R, M ) + ANORM = DLANGE( '1', M, N, A, M, RWORK ) + RESID = DLANGE( '1', M, N, R, M, RWORK ) + IF( ANORM.GT.ZERO ) THEN + RESULT( 1 ) = RESID / (EPS*MAX(1,M)*ANORM) + ELSE + RESULT( 1 ) = ZERO + END IF +* +* Compute |I - Q'*Q| and store in RESULT(2) +* + CALL DLASET( 'Full', M, M, ZERO, ONE, R, M ) + CALL DSYRK( 'U', 'C', M, M, -ONE, Q, M, ONE, R, M ) + RESID = DLANSY( '1', 'Upper', M, R, M, RWORK ) + RESULT( 2 ) = RESID / (EPS*MAX(1,M)) +* +* Generate random m-by-n matrix C and a copy CF +* + DO J=1,N + CALL DLARNV( 2, ISEED, M, C( 1, J ) ) + END DO + CNORM = DLANGE( '1', M, N, C, M, RWORK) + CALL DLACPY( 'Full', M, N, C, M, CF, M ) +* +* Apply Q to C as Q*C +* + srnamt = 'DGEMQR' + CALL DGEMQR( 'L', 'N', M, N, K, AF, M, T, LT, CF, M, + $ WORK, LWORK, INFO) +* +* Compute |Q*C - Q*C| / |C| +* + CALL DGEMM( 'N', 'N', M, N, M, -ONE, Q, M, C, M, ONE, CF, M ) + RESID = DLANGE( '1', M, N, CF, M, RWORK ) + IF( CNORM.GT.ZERO ) THEN + RESULT( 3 ) = RESID / (EPS*MAX(1,M)*CNORM) + ELSE + RESULT( 3 ) = ZERO + END IF +* +* Copy C into CF again +* + CALL DLACPY( 'Full', M, N, C, M, CF, M ) +* +* Apply Q to C as QT*C +* + srnamt = 'DGEMQR' + CALL DGEMQR( 'L', 'T', M, N, K, AF, M, T, LT, CF, M, + $ WORK, LWORK, INFO) +* +* Compute |QT*C - QT*C| / |C| +* + CALL DGEMM( 'T', 'N', M, N, M, -ONE, Q, M, C, M, ONE, CF, M ) + RESID = DLANGE( '1', M, N, CF, M, RWORK ) + IF( CNORM.GT.ZERO ) THEN + RESULT( 4 ) = RESID / (EPS*MAX(1,M)*CNORM) + ELSE + RESULT( 4 ) = ZERO + END IF +* +* Generate random n-by-m matrix D and a copy DF +* + DO J=1,M + CALL DLARNV( 2, ISEED, N, D( 1, J ) ) + END DO + DNORM = DLANGE( '1', N, M, D, N, RWORK) + CALL DLACPY( 'Full', N, M, D, N, DF, N ) +* +* Apply Q to D as D*Q +* + srnamt = 'DGEMQR' + CALL DGEMQR( 'R', 'N', N, M, K, AF, M, T, LT, DF, N, + $ WORK, LWORK, INFO) +* +* Compute |D*Q - D*Q| / |D| +* + CALL DGEMM( 'N', 'N', N, M, M, -ONE, D, N, Q, M, ONE, DF, N ) + RESID = DLANGE( '1', N, M, DF, N, RWORK ) + IF( DNORM.GT.ZERO ) THEN + RESULT( 5 ) = RESID / (EPS*MAX(1,M)*DNORM) + ELSE + RESULT( 5 ) = ZERO + END IF +* +* Copy D into DF again +* + CALL DLACPY( 'Full', N, M, D, N, DF, N ) +* +* Apply Q to D as D*QT +* + CALL DGEMQR( 'R', 'T', N, M, K, AF, M, T, LT, DF, N, + $ WORK, LWORK, INFO) +* +* Compute |D*QT - D*QT| / |D| +* + CALL DGEMM( 'N', 'T', N, M, M, -ONE, D, N, Q, M, ONE, DF, N ) + RESID = DLANGE( '1', N, M, DF, N, RWORK ) + IF( CNORM.GT.ZERO ) THEN + RESULT( 6 ) = RESID / (EPS*MAX(1,M)*DNORM) + ELSE + RESULT( 6 ) = ZERO + END IF +* +* Short and wide +* + ELSE + srnamt = 'DGELQ' + CALL DGELQ( M, N, AF, M, T, LT, WORK, LWORK, INFO ) +* +* +* Generate the n-by-n matrix Q +* + CALL DLASET( 'Full', N, N, ZERO, ONE, Q, N ) + srnamt = 'DGEMLQ' + CALL DGEMLQ( 'R', 'N', N, N, K, AF, M, T, LT, Q, N, + $ WORK, LWORK, INFO ) +* +* Copy R +* + CALL DLASET( 'Full', M, N, ZERO, ZERO, LQ, L ) + CALL DLACPY( 'Lower', M, N, AF, M, LQ, L ) +* +* Compute |L - A*Q'| / |A| and store in RESULT(1) +* + CALL DGEMM( 'N', 'T', M, N, N, -ONE, A, M, Q, N, ONE, LQ, L ) + ANORM = DLANGE( '1', M, N, A, M, RWORK ) + RESID = DLANGE( '1', M, N, LQ, L, RWORK ) + IF( ANORM.GT.ZERO ) THEN + RESULT( 1 ) = RESID / (EPS*MAX(1,N)*ANORM) + ELSE + RESULT( 1 ) = ZERO + END IF +* +* Compute |I - Q'*Q| and store in RESULT(2) +* + CALL DLASET( 'Full', N, N, ZERO, ONE, LQ, L ) + CALL DSYRK( 'U', 'C', N, N, -ONE, Q, N, ONE, LQ, L ) + RESID = DLANSY( '1', 'Upper', N, LQ, L, RWORK ) + RESULT( 2 ) = RESID / (EPS*MAX(1,N)) +* +* Generate random m-by-n matrix C and a copy CF +* + DO J=1,M + CALL DLARNV( 2, ISEED, N, D( 1, J ) ) + END DO + DNORM = DLANGE( '1', N, M, D, N, RWORK) + CALL DLACPY( 'Full', N, M, D, N, DF, N ) +* +* Apply Q to C as Q*C +* + CALL DGEMLQ( 'L', 'N', N, M, K, AF, M, T, LT, DF, N, + $ WORK, LWORK, INFO) +* +* Compute |Q*D - Q*D| / |D| +* + CALL DGEMM( 'N', 'N', N, M, N, -ONE, Q, N, D, N, ONE, DF, N ) + RESID = DLANGE( '1', N, M, DF, N, RWORK ) + IF( DNORM.GT.ZERO ) THEN + RESULT( 3 ) = RESID / (EPS*MAX(1,N)*DNORM) + ELSE + RESULT( 3 ) = ZERO + END IF +* +* Copy D into DF again +* + CALL DLACPY( 'Full', N, M, D, N, DF, N ) +* +* Apply Q to D as QT*D +* + CALL DGEMLQ( 'L', 'T', N, M, K, AF, M, T, LT, DF, N, + $ WORK, LWORK, INFO) +* +* Compute |QT*D - QT*D| / |D| +* + CALL DGEMM( 'T', 'N', N, M, N, -ONE, Q, N, D, N, ONE, DF, N ) + RESID = DLANGE( '1', N, M, DF, N, RWORK ) + IF( DNORM.GT.ZERO ) THEN + RESULT( 4 ) = RESID / (EPS*MAX(1,N)*DNORM) + ELSE + RESULT( 4 ) = ZERO + END IF +* +* Generate random n-by-m matrix D and a copy DF +* + DO J=1,N + CALL DLARNV( 2, ISEED, M, C( 1, J ) ) + END DO + CNORM = DLANGE( '1', M, N, C, M, RWORK) + CALL DLACPY( 'Full', M, N, C, M, CF, M ) +* +* Apply Q to C as C*Q +* + CALL DGEMLQ( 'R', 'N', M, N, K, AF, M, T, LT, CF, M, + $ WORK, LWORK, INFO) +* +* Compute |C*Q - C*Q| / |C| +* + CALL DGEMM( 'N', 'N', M, N, N, -ONE, C, M, Q, N, ONE, CF, M ) + RESID = DLANGE( '1', N, M, DF, N, RWORK ) + IF( CNORM.GT.ZERO ) THEN + RESULT( 5 ) = RESID / (EPS*MAX(1,N)*CNORM) + ELSE + RESULT( 5 ) = ZERO + END IF +* +* Copy C into CF again +* + CALL DLACPY( 'Full', M, N, C, M, CF, M ) +* +* Apply Q to D as D*QT +* + CALL DGEMLQ( 'R', 'T', M, N, K, AF, M, T, LT, CF, M, + $ WORK, LWORK, INFO) +* +* Compute |C*QT - C*QT| / |C| +* + CALL DGEMM( 'N', 'T', M, N, N, -ONE, C, M, Q, N, ONE, CF, M ) + RESID = DLANGE( '1', M, N, CF, M, RWORK ) + IF( CNORM.GT.ZERO ) THEN + RESULT( 6 ) = RESID / (EPS*MAX(1,N)*CNORM) + ELSE + RESULT( 6 ) = ZERO + END IF +* + END IF +* +* Deallocate all arrays +* + DEALLOCATE ( A, AF, Q, R, RWORK, WORK, T, C, D, CF, DF) +* + RETURN + END
\ No newline at end of file diff --git a/TESTING/LIN/ilaenv.f b/TESTING/LIN/ilaenv.f index 80479382..67cc587c 100644 --- a/TESTING/LIN/ilaenv.f +++ b/TESTING/LIN/ilaenv.f @@ -2,20 +2,20 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, * N4 ) -* +* * .. Scalar Arguments .. * CHARACTER*( * ) NAME, OPTS * INTEGER ISPEC, N1, N2, N3, N4 * .. -* +* * *> \par Purpose: * ============= @@ -114,10 +114,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date November 2011 * @@ -162,6 +162,8 @@ * * ===================================================================== * +* .. Local Scalars .. + CHARACTER C1*1, C2*2, C4*2, C3*3, SUBNAM*6 * .. Intrinsic Functions .. INTRINSIC INT, MIN, REAL * .. @@ -184,7 +186,21 @@ * * Return a value from the common block. * - ILAENV = IPARMS( ISPEC ) + IF ( NAME(2:6).EQ.'GEQR ' ) THEN + IF (N3.EQ.2) THEN + ILAENV = IPARMS ( 2 ) + ELSE + ILAENV = IPARMS ( 1 ) + END IF + ELSE IF ( NAME(2:6).EQ.'GELQ ' ) THEN + IF (N3.EQ.2) THEN + ILAENV = IPARMS ( 2 ) + ELSE + ILAENV = IPARMS ( 1 ) + END IF + ELSE + ILAENV = IPARMS( ISPEC ) + END IF * ELSE IF( ISPEC.EQ.6 ) THEN * diff --git a/TESTING/LIN/schkaa.f b/TESTING/LIN/schkaa.f index a6bfa101..480dd1d2 100644 --- a/TESTING/LIN/schkaa.f +++ b/TESTING/LIN/schkaa.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * PROGRAM SCHKAA -* +* * *> \par Purpose: * ============= @@ -94,10 +94,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -664,33 +664,6 @@ WRITE( NOUT, FMT = 9988 )PATH END IF * - ELSE IF( LSAMEN( 2, C2, 'SA' ) ) THEN -* -* SY: symmetric indefinite matrices, -* with partial (Aasen's) pivoting algorithm -* - NTYPES = 10 - CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) -* - IF( TSTCHK ) THEN - CALL SCHKSY_AASEN( DOTYPE, NN, NVAL, NNB2, NBVAL2, NNS, - $ NSVAL, THRESH, TSTERR, LDA, - $ A( 1, 1 ), A( 1, 2 ), A( 1, 3 ), - $ B( 1, 1 ), B( 1, 2 ), B( 1, 3 ), - $ WORK, RWORK, IWORK, NOUT ) - ELSE - WRITE( NOUT, FMT = 9989 )PATH - END IF -* - IF( TSTDRV ) THEN - CALL SDRVSY_AASEN( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, - $ LDA, A( 1, 1 ), A( 1, 2 ), A( 1, 3 ), - $ B( 1, 1 ), B( 1, 2 ), B( 1, 3 ), - $ WORK, RWORK, IWORK, NOUT ) - ELSE - WRITE( NOUT, FMT = 9988 )PATH - END IF -* ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN * * SP: symmetric indefinite packed matrices, @@ -895,7 +868,7 @@ * QT: QRT routines for general matrices * IF( TSTCHK ) THEN - CALL SCHKQRT( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, + CALL SCHKQRT( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, $ NBVAL, NOUT ) ELSE WRITE( NOUT, FMT = 9989 )PATH @@ -906,7 +879,40 @@ * QX: QRT routines for triangular-pentagonal matrices * IF( TSTCHK ) THEN - CALL SCHKQRTP( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, + CALL SCHKQRTP( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, + $ NBVAL, NOUT ) + ELSE + WRITE( NOUT, FMT = 9989 )PATH + END IF +* + ELSE IF( LSAMEN( 2, C2, 'TQ' ) ) THEN +* +* TQ: LQT routines for general matrices +* + IF( TSTCHK ) THEN + CALL SCHKLQT( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, + $ NBVAL, NOUT ) + ELSE + WRITE( NOUT, FMT = 9989 )PATH + END IF +* + ELSE IF( LSAMEN( 2, C2, 'XQ' ) ) THEN +* +* XQ: LQT routines for triangular-pentagonal matrices +* + IF( TSTCHK ) THEN + CALL SCHKLQTP( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, + $ NBVAL, NOUT ) + ELSE + WRITE( NOUT, FMT = 9989 )PATH + END IF +* + ELSE IF( LSAMEN( 2, C2, 'TS' ) ) THEN +* +* TS: QR routines for tall-skinny matrices +* + IF( TSTCHK ) THEN + CALL SCHKTSQR( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, $ NBVAL, NOUT ) ELSE WRITE( NOUT, FMT = 9989 )PATH diff --git a/TESTING/LIN/schklqt.f b/TESTING/LIN/schklqt.f new file mode 100644 index 00000000..fd449b1a --- /dev/null +++ b/TESTING/LIN/schklqt.f @@ -0,0 +1,210 @@ +*> \brief \b SCHKLQT +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SCHKLQT( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, +* NBVAL, NOUT ) +* +* .. Scalar Arguments .. +* LOGICAL TSTERR +* INTEGER NM, NN, NNB, NOUT +* REAL THRESH +* .. +* .. Array Arguments .. +* INTEGER MVAL( * ), NBVAL( * ), NVAL( * ) +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SCHKLQT tests SGELQT and SGEMLQT. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] THRESH +*> \verbatim +*> THRESH is REAL +*> The threshold value for the test ratios. A result is +*> included in the output file if RESULT >= THRESH. To have +*> every test ratio printed, use THRESH = 0. +*> \endverbatim +*> +*> \param[in] TSTERR +*> \verbatim +*> TSTERR is LOGICAL +*> Flag that indicates whether error exits are to be tested. +*> \endverbatim +*> +*> \param[in] NM +*> \verbatim +*> NM is INTEGER +*> The number of values of M contained in the vector MVAL. +*> \endverbatim +*> +*> \param[in] MVAL +*> \verbatim +*> MVAL is INTEGER array, dimension (NM) +*> The values of the matrix row dimension M. +*> \endverbatim +*> +*> \param[in] NN +*> \verbatim +*> NN is INTEGER +*> The number of values of N contained in the vector NVAL. +*> \endverbatim +*> +*> \param[in] NVAL +*> \verbatim +*> NVAL is INTEGER array, dimension (NN) +*> The values of the matrix column dimension N. +*> \endverbatim +*> +*> \param[in] NNB +*> \verbatim +*> NNB is INTEGER +*> The number of values of NB contained in the vector NBVAL. +*> \endverbatim +*> +*> \param[in] NBVAL +*> \verbatim +*> NBVAL is INTEGER array, dimension (NBVAL) +*> The values of the blocksize NB. +*> \endverbatim +*> +*> \param[in] NOUT +*> \verbatim +*> NOUT is INTEGER +*> The unit number for output. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2011 +* +*> \ingroup double_lin +* +* ===================================================================== + SUBROUTINE SCHKLQT( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, + $ NBVAL, NOUT ) + IMPLICIT NONE +* +* -- LAPACK test routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + LOGICAL TSTERR + INTEGER NM, NN, NNB, NOUT + REAL THRESH +* .. +* .. Array Arguments .. + INTEGER MVAL( * ), NBVAL( * ), NVAL( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER NTESTS + PARAMETER ( NTESTS = 6 ) +* .. +* .. Local Scalars .. + CHARACTER*3 PATH + INTEGER I, J, K, T, M, N, NB, NFAIL, NERRS, NRUN, + $ MINMN +* +* .. Local Arrays .. + REAL RESULT( NTESTS ) +* .. +* .. External Subroutines .. + EXTERNAL ALAERH, ALAHD, ALASUM, SERRLQT, SLQT04 +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, NUNIT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NUNIT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Executable Statements .. +* +* Initialize constants +* + PATH( 1: 1 ) = 'S' + PATH( 2: 3 ) = 'TQ' + NRUN = 0 + NFAIL = 0 + NERRS = 0 +* +* Test the error exits +* + IF( TSTERR ) CALL SERRLQT( PATH, NOUT ) + INFOT = 0 +* +* Do for each value of M in MVAL. +* + DO I = 1, NM + M = MVAL( I ) +* +* Do for each value of N in NVAL. +* + DO J = 1, NN + N = NVAL( J ) +* +* Do for each possible value of NB +* + MINMN = MIN( M, N ) + DO K = 1, NNB + NB = NBVAL( K ) +* +* Test DGELQT and DGEMLQT +* + IF( (NB.LE.MINMN).AND.(NB.GT.0) ) THEN + CALL SLQT04( M, N, NB, RESULT ) +* +* Print information about the tests that did not +* pass the threshold. +* + DO T = 1, NTESTS + IF( RESULT( T ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 )M, N, NB, + $ T, RESULT( T ) + NFAIL = NFAIL + 1 + END IF + END DO + NRUN = NRUN + NTESTS + END IF + END DO + END DO + END DO +* +* Print a summary of the results. +* + CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) +* + 9999 FORMAT( ' M=', I5, ', N=', I5, ', NB=', I4, + $ ' test(', I2, ')=', G12.5 ) + RETURN +* +* End of SCHKLQT +* + END diff --git a/TESTING/LIN/schklqtp.f b/TESTING/LIN/schklqtp.f new file mode 100644 index 00000000..d85ef8d1 --- /dev/null +++ b/TESTING/LIN/schklqtp.f @@ -0,0 +1,215 @@ +*> \brief \b SCHKLQTP +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SCHKLQTP( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, +* NBVAL, NOUT ) +* +* .. Scalar Arguments .. +* LOGICAL TSTERR +* INTEGER NM, NN, NNB, NOUT +* REAL THRESH +* .. +* .. Array Arguments .. +* INTEGER MVAL( * ), NBVAL( * ), NVAL( * ) +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SCHKLQTP tests STPLQT and STPMLQT. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] THRESH +*> \verbatim +*> THRESH is REAL +*> The threshold value for the test ratios. A result is +*> included in the output file if RESULT >= THRESH. To have +*> every test ratio printed, use THRESH = 0. +*> \endverbatim +*> +*> \param[in] TSTERR +*> \verbatim +*> TSTERR is LOGICAL +*> Flag that indicates whether error exits are to be tested. +*> \endverbatim +*> +*> \param[in] NM +*> \verbatim +*> NM is INTEGER +*> The number of values of M contained in the vector MVAL. +*> \endverbatim +*> +*> \param[in] MVAL +*> \verbatim +*> MVAL is INTEGER array, dimension (NM) +*> The values of the matrix row dimension M. +*> \endverbatim +*> +*> \param[in] NN +*> \verbatim +*> NN is INTEGER +*> The number of values of N contained in the vector NVAL. +*> \endverbatim +*> +*> \param[in] NVAL +*> \verbatim +*> NVAL is INTEGER array, dimension (NN) +*> The values of the matrix column dimension N. +*> \endverbatim +*> +*> \param[in] NNB +*> \verbatim +*> NNB is INTEGER +*> The number of values of NB contained in the vector NBVAL. +*> \endverbatim +*> +*> \param[in] NBVAL +*> \verbatim +*> NBVAL is INTEGER array, dimension (NBVAL) +*> The values of the blocksize NB. +*> \endverbatim +*> +*> \param[in] NOUT +*> \verbatim +*> NOUT is INTEGER +*> The unit number for output. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2011 +* +*> \ingroup double_lin +* +* ===================================================================== + SUBROUTINE SCHKLQTP( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, + $ NBVAL, NOUT ) + IMPLICIT NONE +* +* -- LAPACK test routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + LOGICAL TSTERR + INTEGER NM, NN, NNB, NOUT + REAL THRESH +* .. +* .. Array Arguments .. + INTEGER MVAL( * ), NBVAL( * ), NVAL( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER NTESTS + PARAMETER ( NTESTS = 6 ) +* .. +* .. Local Scalars .. + CHARACTER*3 PATH + INTEGER I, J, K, L, T, M, N, NB, NFAIL, NERRS, NRUN, + $ MINMN +* .. +* .. Local Arrays .. + REAL RESULT( NTESTS ) +* .. +* .. External Subroutines .. + EXTERNAL ALAERH, ALAHD, ALASUM, DERRLQTP, DLQT04 +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, NUNIT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NUNIT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Executable Statements .. +* +* Initialize constants +* + PATH( 1: 1 ) = 'S' + PATH( 2: 3 ) = 'XQ' + NRUN = 0 + NFAIL = 0 + NERRS = 0 +* +* Test the error exits +* + IF( TSTERR ) CALL SERRLQTP( PATH, NOUT ) + INFOT = 0 +* +* Do for each value of M +* + DO I = 1, NM + M = MVAL( I ) +* +* Do for each value of N +* + DO J = 1, NN + N = NVAL( J ) +* +* Do for each value of L +* + MINMN = MIN( M, N ) + DO L = 0, MINMN, MAX( MINMN, 1 ) +* +* Do for each possible value of NB +* + DO K = 1, NNB + NB = NBVAL( K ) +* +* Test DTPLQT and DTPMLQT +* + IF( (NB.LE.M).AND.(NB.GT.0) ) THEN + CALL SLQT05( M, N, L, NB, RESULT ) +* +* Print information about the tests that did not +* pass the threshold. +* + DO T = 1, NTESTS + IF( RESULT( T ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 )M, N, NB, L, + $ T, RESULT( T ) + NFAIL = NFAIL + 1 + END IF + END DO + NRUN = NRUN + NTESTS + END IF + END DO + END DO + END DO + END DO +* +* Print a summary of the results. +* + CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) +* + 9999 FORMAT( ' M=', I5, ', N=', I5, ', NB=', I4,' L=', I4, + $ ' test(', I2, ')=', G12.5 ) + RETURN +* +* End of SCHKQRTP +* + END diff --git a/TESTING/LIN/schktsqr.f b/TESTING/LIN/schktsqr.f new file mode 100644 index 00000000..a4303143 --- /dev/null +++ b/TESTING/LIN/schktsqr.f @@ -0,0 +1,257 @@ +*> \brief \b SCHKQRT +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SCHKTSQR( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, +* NBVAL, NOUT ) +* +* .. Scalar Arguments .. +* LOGICAL TSTERR +* INTEGER NM, NN, NNB, NOUT +* REAL THRESH +* .. +* .. Array Arguments .. +* INTEGER MVAL( * ), NBVAL( * ), NVAL( * ) +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SCHKTSQR tests SGETSQR and SORMTSQR. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] THRESH +*> \verbatim +*> THRESH is REAL +*> The threshold value for the test ratios. A result is +*> included in the output file if RESULT >= THRESH. To have +*> every test ratio printed, use THRESH = 0. +*> \endverbatim +*> +*> \param[in] TSTERR +*> \verbatim +*> TSTERR is LOGICAL +*> Flag that indicates whether error exits are to be tested. +*> \endverbatim +*> +*> \param[in] NM +*> \verbatim +*> NM is INTEGER +*> The number of values of M contained in the vector MVAL. +*> \endverbatim +*> +*> \param[in] MVAL +*> \verbatim +*> MVAL is INTEGER array, dimension (NM) +*> The values of the matrix row dimension M. +*> \endverbatim +*> +*> \param[in] NN +*> \verbatim +*> NN is INTEGER +*> The number of values of N contained in the vector NVAL. +*> \endverbatim +*> +*> \param[in] NVAL +*> \verbatim +*> NVAL is INTEGER array, dimension (NN) +*> The values of the matrix column dimension N. +*> \endverbatim +*> +*> \param[in] NNB +*> \verbatim +*> NNB is INTEGER +*> The number of values of NB contained in the vector NBVAL. +*> \endverbatim +*> +*> \param[in] NBVAL +*> \verbatim +*> NBVAL is INTEGER array, dimension (NBVAL) +*> The values of the blocksize NB. +*> \endverbatim +*> +*> \param[in] NOUT +*> \verbatim +*> NOUT is INTEGER +*> The unit number for output. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2011 +* +*> \ingroup double_lin +* +* ===================================================================== + SUBROUTINE SCHKTSQR( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, + $ NBVAL, NOUT ) + IMPLICIT NONE +* +* -- LAPACK test routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + LOGICAL TSTERR + INTEGER NM, NN, NNB, NOUT + REAL THRESH +* .. +* .. Array Arguments .. + INTEGER MVAL( * ), NBVAL( * ), NVAL( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER NTESTS + PARAMETER ( NTESTS = 6 ) +* .. +* .. Local Scalars .. + CHARACTER*3 PATH + INTEGER I, J, K, T, M, N, NB, NFAIL, NERRS, NRUN, INB, + $ MINMN, MB, IMB +* +* .. Local Arrays .. + REAL RESULT( NTESTS ) +* .. +* .. External Subroutines .. + EXTERNAL ALAERH, ALAHD, ALASUM, SERRTSQR, + $ STSQR01, XLAENV +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, NUNIT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NUNIT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Executable Statements .. +* +* Initialize constants +* + PATH( 1: 1 ) = 'S' + PATH( 2: 3 ) = 'TS' + NRUN = 0 + NFAIL = 0 + NERRS = 0 +* +* Test the error exits +* + IF( TSTERR ) CALL SERRTSQR( PATH, NOUT ) + INFOT = 0 +* +* Do for each value of M in MVAL. +* + DO I = 1, NM + M = MVAL( I ) +* +* Do for each value of N in NVAL. +* + DO J = 1, NN + N = NVAL( J ) + IF (MIN(M,N).NE.0) THEN + DO INB = 1, NNB + MB = NBVAL( INB ) + CALL XLAENV( 1, MB ) + DO IMB = 1, NNB + NB = NBVAL( IMB ) + CALL XLAENV( 2, NB ) +* +* Test SGEQR and SGEMQR +* + CALL STSQR01('TS', M, N, MB, NB, RESULT ) +* +* Print information about the tests that did not +* pass the threshold. +* + DO T = 1, NTESTS + IF( RESULT( T ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 )M, N, MB, NB, + $ T, RESULT( T ) + NFAIL = NFAIL + 1 + END IF + END DO + NRUN = NRUN + NTESTS + END DO + END DO + END IF + END DO + END DO +* +* Do for each value of M in MVAL. +* + DO I = 1, NM + M = MVAL( I ) +* +* Do for each value of N in NVAL. +* + DO J = 1, NN + N = NVAL( J ) + IF (MIN(M,N).NE.0) THEN + DO INB = 1, NNB + MB = NBVAL( INB ) + CALL XLAENV( 1, MB ) + DO IMB = 1, NNB + NB = NBVAL( IMB ) + CALL XLAENV( 2, NB ) +* +* Test SGEQR and SGEMQR +* + CALL STSQR01('SW', M, N, MB, NB, RESULT ) +* +* Print information about the tests that did not +* pass the threshold. +* + DO T = 1, NTESTS + IF( RESULT( T ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9998 )M, N, MB, NB, + $ T, RESULT( T ) + NFAIL = NFAIL + 1 + END IF + END DO + NRUN = NRUN + NTESTS + END DO + END DO + END IF + END DO + END DO +* +* Print a summary of the results. +* + CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) +* + 9999 FORMAT( 'TS: M=', I5, ', N=', I5, ', MB=', I5, + $ ', NB=', I5,' test(', I2, ')=', G12.5 ) + 9998 FORMAT( 'SW: M=', I5, ', N=', I5, ', MB=', I5, + $ ', NB=', I5,' test(', I2, ')=', G12.5 ) + RETURN +* +* End of SCHKQRT +* + END diff --git a/TESTING/LIN/sdrvls.f b/TESTING/LIN/sdrvls.f index 4db6f887..d18ce595 100644 --- a/TESTING/LIN/sdrvls.f +++ b/TESTING/LIN/sdrvls.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE SDRVLS( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, NNB, * NBVAL, NXVAL, THRESH, TSTERR, A, COPYA, B, * COPYB, C, S, COPYS, WORK, IWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NM, NN, NNB, NNS, NOUT @@ -24,14 +24,14 @@ * REAL A( * ), B( * ), C( * ), COPYA( * ), COPYB( * ), * $ COPYS( * ), S( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= *> *> \verbatim *> -*> SDRVLS tests the least squares driver routines SGELS, SGELSS, SGELSY +*> SDRVLS tests the least squares driver routines SGELS, SGETSLS, SGELSS, SGELSY, *> and SGELSD. *> \endverbatim * @@ -46,14 +46,14 @@ *> .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. *> The matrix of type j is generated as follows: *> j=1: A = U*D*V where U and V are random orthogonal matrices -*> and D has random entries (> 0.1) taken from a uniform +*> and D has random entries (> 0.1) taken from a uniform *> distribution (0,1). A is full rank. *> j=2: The same of 1, but A is scaled up. *> j=3: The same of 1, but A is scaled down. *> j=4: A = U*D*V where U and V are random orthogonal matrices *> and D has 3*min(M,N)/4 random entries (> 0.1) taken *> from a uniform distribution (0,1) and the remaining -*> entries set to 0. A is rank-deficient. +*> entries set to 0. A is rank-deficient. *> j=5: The same of 4, but A is scaled up. *> j=6: The same of 5, but A is scaled down. *> \endverbatim @@ -189,14 +189,14 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date November 2015 * -*> \ingroup single_lin +*> \ingroup double_lin * * ===================================================================== SUBROUTINE SDRVLS( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, NNB, @@ -225,7 +225,7 @@ * * .. Parameters .. INTEGER NTESTS - PARAMETER ( NTESTS = 14 ) + PARAMETER ( NTESTS = 16 ) INTEGER SMLSIZ PARAMETER ( SMLSIZ = 25 ) REAL ONE, TWO, ZERO @@ -234,10 +234,10 @@ * .. Local Scalars .. CHARACTER TRANS CHARACTER*3 PATH - INTEGER CRANK, I, IM, IN, INB, INFO, INS, IRANK, - $ ISCALE, ITRAN, ITYPE, J, K, LDA, LDB, LDWORK, - $ LWLSY, LWORK, M, MNMIN, N, NB, NCOLS, NERRS, - $ NFAIL, NLVL, NRHS, NROWS, NRUN, RANK + INTEGER CRANK, I, IM, IN, INB, INFO, INS, IRANK, + $ ISCALE, ITRAN, ITYPE, J, K, LDA, LDB, LDWORK, + $ LWLSY, LWORK, M, MNMIN, N, NB, NCOLS, NERRS, + $ NFAIL, NLVL, NRHS, NROWS, NRUN, RANK, MB, LWTS REAL EPS, NORMA, NORMB, RCOND * .. * .. Local Arrays .. @@ -251,11 +251,11 @@ * .. External Subroutines .. EXTERNAL ALAERH, ALAHD, ALASVM, SAXPY, SERRLS, SGELS, $ SGELSD, SGELSS, SGELSY, SGEMM, SLACPY, - $ SLARNV, SQRT13, SQRT15, SQRT16, SSCAL, + $ SLARNV, SLASRT, SQRT13, SQRT15, SQRT16, SSCAL, $ XLAENV * .. * .. Intrinsic Functions .. - INTRINSIC INT, LOG, MAX, MIN, REAL, SQRT + INTRINSIC REAL, INT, LOG, MAX, MIN, SQRT * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -273,7 +273,7 @@ * * Initialize constants and the random number seed. * - PATH( 1: 1 ) = 'Single precision' + PATH( 1: 1 ) = 'SINGLE PRECISION' PATH( 2: 3 ) = 'LS' NRUN = 0 NFAIL = 0 @@ -299,6 +299,8 @@ IF( ( NM.EQ.0 .OR. NN.EQ.0 ) .AND. THRESH.EQ.ZERO ) $ CALL ALAHD( NOUT, PATH ) INFOT = 0 + CALL XLAENV( 2, 2 ) + CALL XLAENV( 9, SMLSIZ ) * DO 150 IM = 1, NM M = MVAL( IM ) @@ -306,8 +308,14 @@ * DO 140 IN = 1, NN N = NVAL( IN ) - MNMIN = MIN( M, N ) + MNMIN = MAX(MIN( M, N ),1) LDB = MAX( 1, M, N ) + MB = (MNMIN+1) + IF(MINMN.NE.MB) THEN + LWTS = (((LDB-MB)/(MB-MNMIN))*MNMIN+MNMIN*2)*MB+5 + ELSE + LWTS = 2*MINMN+5 + END IF * DO 130 INS = 1, NNS NRHS = NSVAL( INS ) @@ -315,7 +323,8 @@ $ REAL( SMLSIZ+1 ) ) / LOG( TWO ) ) + 1, 0 ) LWORK = MAX( 1, ( M+NRHS )*( N+2 ), ( N+NRHS )*( M+2 ), $ M*N+4*MNMIN+MAX( M, N ), 12*MNMIN+2*MNMIN*SMLSIZ+ - $ 8*MNMIN*NLVL+MNMIN*NRHS+(SMLSIZ+1)**2 ) + $ 8*MNMIN*NLVL+MNMIN*NRHS+(SMLSIZ+1)**2,LWTS) + $ * DO 120 IRANK = 1, 2 DO 110 ISCALE = 1, 3 @@ -424,6 +433,110 @@ NRUN = NRUN + 2 30 CONTINUE 40 CONTINUE +* +* +* Test SGETSLS +* +* Generate a matrix of scaling type ISCALE +* + CALL SQRT13( ISCALE, M, N, COPYA, LDA, NORMA, + $ ISEED ) + DO 65 INB = 1, NNB + MB = NBVAL( INB ) + CALL XLAENV( 1, MB ) + DO 62 IMB = 1, NNB + NB = NBVAL( IMB ) + CALL XLAENV( 2, NB ) +* + DO 60 ITRAN = 1, 2 + IF( ITRAN.EQ.1 ) THEN + TRANS = 'N' + NROWS = M + NCOLS = N + ELSE + TRANS = 'T' + NROWS = N + NCOLS = M + END IF + LDWORK = MAX( 1, NCOLS ) +* +* Set up a consistent rhs +* + IF( NCOLS.GT.0 ) THEN + CALL SLARNV( 2, ISEED, NCOLS*NRHS, + $ WORK ) + CALL SSCAL( NCOLS*NRHS, + $ ONE / REAL( NCOLS ), WORK, + $ 1 ) + END IF + CALL SGEMM( TRANS, 'No transpose', NROWS, + $ NRHS, NCOLS, ONE, COPYA, LDA, + $ WORK, LDWORK, ZERO, B, LDB ) + CALL SLACPY( 'Full', NROWS, NRHS, B, LDB, + $ COPYB, LDB ) +* +* Solve LS or overdetermined system +* + IF( M.GT.0 .AND. N.GT.0 ) THEN + CALL SLACPY( 'Full', M, N, COPYA, LDA, + $ A, LDA ) + CALL SLACPY( 'Full', NROWS, NRHS, + $ COPYB, LDB, B, LDB ) + END IF + SRNAMT = 'SGETSLS ' + CALL SGETSLS( TRANS, M, N, NRHS, A, + $ LDA, B, LDB, WORK, LWORK, INFO ) + IF( INFO.NE.0 ) + $ CALL ALAERH( PATH, 'SGETSLS ', INFO, 0, + $ TRANS, M, N, NRHS, -1, NB, + $ ITYPE, NFAIL, NERRS, + $ NOUT ) +* +* Check correctness of results +* + LDWORK = MAX( 1, NROWS ) + IF( NROWS.GT.0 .AND. NRHS.GT.0 ) + $ CALL SLACPY( 'Full', NROWS, NRHS, + $ COPYB, LDB, C, LDB ) + CALL SQRT16( TRANS, M, N, NRHS, COPYA, + $ LDA, B, LDB, C, LDB, WORK, + $ RESULT( 15 ) ) +* + IF( ( ITRAN.EQ.1 .AND. M.GE.N ) .OR. + $ ( ITRAN.EQ.2 .AND. M.LT.N ) ) THEN +* +* Solving LS system +* + RESULT( 16 ) = SQRT17( TRANS, 1, M, N, + $ NRHS, COPYA, LDA, B, LDB, + $ COPYB, LDB, C, WORK, + $ LWORK ) + ELSE +* +* Solving overdetermined system +* + RESULT( 16 ) = SQRT14( TRANS, M, N, + $ NRHS, COPYA, LDA, B, LDB, + $ WORK, LWORK ) + END IF +* +* Print information about the tests that +* did not pass the threshold. +* + DO 50 K = 15, 16 + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9997 )TRANS, M, + $ N, NRHS, MB, NB, ITYPE, K, + $ RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 50 CONTINUE + NRUN = NRUN + 2 + 60 CONTINUE + 62 CONTINUE + 65 CONTINUE END IF * * Generate a matrix of scaling type ISCALE and rank @@ -626,7 +739,7 @@ * Print information about the tests that did not * pass the threshold. * - DO 90 K = 3, NTESTS + DO 90 K = 3, 14 IF( RESULT( K ).GE.THRESH ) THEN IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) $ CALL ALAHD( NOUT, PATH ) @@ -635,7 +748,7 @@ NFAIL = NFAIL + 1 END IF 90 CONTINUE - NRUN = NRUN + 12 + NRUN = NRUN + 12 * 100 CONTINUE 110 CONTINUE @@ -652,6 +765,9 @@ $ ', NB=', I4, ', type', I2, ', test(', I2, ')=', G12.5 ) 9998 FORMAT( ' M=', I5, ', N=', I5, ', NRHS=', I4, ', NB=', I4, $ ', type', I2, ', test(', I2, ')=', G12.5 ) + 9997 FORMAT( ' TRANS=''', A1,' M=', I5, ', N=', I5, ', NRHS=', I4, + $ ', MB=', I4,', NB=', I4,', type', I2, + $ ', test(', I2, ')=', G12.5 ) RETURN * * End of SDRVLS diff --git a/TESTING/LIN/serrlqt.f b/TESTING/LIN/serrlqt.f new file mode 100644 index 00000000..2c2c575b --- /dev/null +++ b/TESTING/LIN/serrlqt.f @@ -0,0 +1,197 @@ +*> \brief \b SERRLQT +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SERRLQT( PATH, NUNIT ) +* +* .. Scalar Arguments .. +* CHARACTER*3 PATH +* INTEGER NUNIT +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DERRLQT tests the error exits for the DOUBLE PRECISION routines +*> that use the LQT decomposition of a general matrix. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] PATH +*> \verbatim +*> PATH is CHARACTER*3 +*> The LAPACK path name for the routines to be tested. +*> \endverbatim +*> +*> \param[in] NUNIT +*> \verbatim +*> NUNIT is INTEGER +*> The unit number for output. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2011 +* +*> \ingroup double_lin +* +* ===================================================================== + SUBROUTINE SERRLQT( PATH, NUNIT ) + IMPLICIT NONE +* +* -- LAPACK test routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + CHARACTER*3 PATH + INTEGER NUNIT +* .. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER NMAX + PARAMETER ( NMAX = 2 ) +* .. +* .. Local Scalars .. + INTEGER I, INFO, J +* .. +* .. Local Arrays .. + REAL A( NMAX, NMAX ), T( NMAX, NMAX ), W( NMAX ), + $ C( NMAX, NMAX ) +* .. +* .. External Subroutines .. + EXTERNAL ALAESM, CHKXER, SGELQT3, SGELQT, + $ SGEMLQT +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, NOUT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NOUT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Intrinsic Functions .. + INTRINSIC REAL +* .. +* .. Executable Statements .. +* + NOUT = NUNIT + WRITE( NOUT, FMT = * ) +* +* Set the variables to innocuous values. +* + DO J = 1, NMAX + DO I = 1, NMAX + A( I, J ) = 1.D0 / REAL( I+J ) + C( I, J ) = 1.D0 / REAL( I+J ) + T( I, J ) = 1.D0 / REAL( I+J ) + END DO + W( J ) = 0.D0 + END DO + OK = .TRUE. +* +* Error exits for LQT factorization +* +* SGELQT +* + SRNAMT = 'SGELQT' + INFOT = 1 + CALL SGELQT( -1, 0, 1, A, 1, T, 1, W, INFO ) + CALL CHKXER( 'SGELQT', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SGELQT( 0, -1, 1, A, 1, T, 1, W, INFO ) + CALL CHKXER( 'SGELQT', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL SGELQT( 0, 0, 0, A, 1, T, 1, W, INFO ) + CALL CHKXER( 'SGELQT', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL SGELQT( 2, 1, 1, A, 1, T, 1, W, INFO ) + CALL CHKXER( 'SGELQT', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL SGELQT( 2, 2, 2, A, 2, T, 1, W, INFO ) + CALL CHKXER( 'SGELQT', INFOT, NOUT, LERR, OK ) +* +* SGELQT3 +* + SRNAMT = 'SGELQT3' + INFOT = 1 + CALL SGELQT3( -1, 0, A, 1, T, 1, INFO ) + CALL CHKXER( 'SGELQT3', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SGELQT3( 0, -1, A, 1, T, 1, INFO ) + CALL CHKXER( 'SGELQT3', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SGELQT3( 2, 2, A, 1, T, 1, INFO ) + CALL CHKXER( 'SGELQT3', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL SGELQT3( 2, 2, A, 2, T, 1, INFO ) + CALL CHKXER( 'SGELQT3', INFOT, NOUT, LERR, OK ) +* +* SGEMLQT +* + SRNAMT = 'SGEMLQT' + INFOT = 1 + CALL SGEMLQT( '/', 'N', 0, 0, 0, 1, A, 1, T, 1, C, 1, W, INFO ) + CALL CHKXER( 'SGEMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SGEMLQT( 'L', '/', 0, 0, 0, 1, A, 1, T, 1, C, 1, W, INFO ) + CALL CHKXER( 'SGEMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL SGEMLQT( 'L', 'N', -1, 0, 0, 1, A, 1, T, 1, C, 1, W, INFO ) + CALL CHKXER( 'SGEMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SGEMLQT( 'L', 'N', 0, -1, 0, 1, A, 1, T, 1, C, 1, W, INFO ) + CALL CHKXER( 'SGEMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL SGEMLQT( 'L', 'N', 0, 0, -1, 1, A, 1, T, 1, C, 1, W, INFO ) + CALL CHKXER( 'SGEMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL SGEMLQT( 'R', 'N', 0, 0, -1, 1, A, 1, T, 1, C, 1, W, INFO ) + CALL CHKXER( 'SGEMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL SGEMLQT( 'L', 'N', 0, 0, 0, 0, A, 1, T, 1, C, 1, W, INFO ) + CALL CHKXER( 'SGEMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL SGEMLQT( 'R', 'N', 2, 2, 2, 1, A, 1, T, 1, C, 1, W, INFO ) + CALL CHKXER( 'SGEMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL SGEMLQT( 'L', 'N', 2, 2, 2, 1, A, 1, T, 1, C, 1, W, INFO ) + CALL CHKXER( 'SGEMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL SGEMLQT( 'R', 'N', 1, 1, 1, 1, A, 1, T, 0, C, 1, W, INFO ) + CALL CHKXER( 'SGEMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 12 + CALL SGEMLQT( 'L', 'N', 1, 1, 1, 1, A, 1, T, 1, C, 0, W, INFO ) + CALL CHKXER( 'SGEMLQT', INFOT, NOUT, LERR, OK ) +* +* Print a summary line. +* + CALL ALAESM( PATH, OK, NOUT ) +* + RETURN +* +* End of SERRLQT +* + END diff --git a/TESTING/LIN/serrlqtp.f b/TESTING/LIN/serrlqtp.f new file mode 100644 index 00000000..319ee91c --- /dev/null +++ b/TESTING/LIN/serrlqtp.f @@ -0,0 +1,225 @@ +*> \brief \b DERRLQTP +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SERRLQTP( PATH, NUNIT ) +* +* .. Scalar Arguments .. +* CHARACTER*3 PATH +* INTEGER NUNIT +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SERRLQTP tests the error exits for the REAL routines +*> that use the LQT decomposition of a triangular-pentagonal matrix. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] PATH +*> \verbatim +*> PATH is CHARACTER*3 +*> The LAPACK path name for the routines to be tested. +*> \endverbatim +*> +*> \param[in] NUNIT +*> \verbatim +*> NUNIT is INTEGER +*> The unit number for output. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2011 +* +*> \ingroup double_lin +* +* ===================================================================== + SUBROUTINE SERRLQTP( PATH, NUNIT ) + IMPLICIT NONE +* +* -- LAPACK test routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + CHARACTER*3 PATH + INTEGER NUNIT +* .. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER NMAX + PARAMETER ( NMAX = 2 ) +* .. +* .. Local Scalars .. + INTEGER I, INFO, J +* .. +* .. Local Arrays .. + REAL A( NMAX, NMAX ), T( NMAX, NMAX ), W( NMAX ), + $ B( NMAX, NMAX ), C( NMAX, NMAX ) +* .. +* .. External Subroutines .. + EXTERNAL ALAESM, CHKXER, STPLQT2, STPLQT, + $ STPMLQT +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, NOUT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NOUT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Intrinsic Functions .. + INTRINSIC REAL +* .. +* .. Executable Statements .. +* + NOUT = NUNIT + WRITE( NOUT, FMT = * ) +* +* Set the variables to innocuous values. +* + DO J = 1, NMAX + DO I = 1, NMAX + A( I, J ) = 1.D0 / REAL( I+J ) + C( I, J ) = 1.D0 / REAL( I+J ) + T( I, J ) = 1.D0 / REAL( I+J ) + END DO + W( J ) = 0.0 + END DO + OK = .TRUE. +* +* Error exits for TPLQT factorization +* +* STPLQT +* + SRNAMT = 'STPLQT' + INFOT = 1 + CALL STPLQT( -1, 1, 0, 1, A, 1, B, 1, T, 1, W, INFO ) + CALL CHKXER( 'STPLQT', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL STPLQT( 1, -1, 0, 1, A, 1, B, 1, T, 1, W, INFO ) + CALL CHKXER( 'STPLQT', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL STPLQT( 0, 1, -1, 1, A, 1, B, 1, T, 1, W, INFO ) + CALL CHKXER( 'STPLQT', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL STPLQT( 0, 1, 1, 1, A, 1, B, 1, T, 1, W, INFO ) + CALL CHKXER( 'STPLQT', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL STPLQT( 0, 1, 0, 0, A, 1, B, 1, T, 1, W, INFO ) + CALL CHKXER( 'STPLQT', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL STPLQT( 1, 1, 0, 2, A, 1, B, 1, T, 1, W, INFO ) + CALL CHKXER( 'STPLQT', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL STPLQT( 2, 1, 0, 2, A, 1, B, 1, T, 1, W, INFO ) + CALL CHKXER( 'STPLQT', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL STPLQT( 2, 1, 0, 1, A, 2, B, 1, T, 1, W, INFO ) + CALL CHKXER( 'STPLQT', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL STPLQT( 2, 2, 1, 2, A, 2, B, 2, T, 1, W, INFO ) + CALL CHKXER( 'STPLQT', INFOT, NOUT, LERR, OK ) +* +* STPLQT2 +* + SRNAMT = 'STPLQT2' + INFOT = 1 + CALL STPLQT2( -1, 0, 0, A, 1, B, 1, T, 1, INFO ) + CALL CHKXER( 'STPLQT2', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL STPLQT2( 0, -1, 0, A, 1, B, 1, T, 1, INFO ) + CALL CHKXER( 'STPLQT2', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL STPLQT2( 0, 0, -1, A, 1, B, 1, T, 1, INFO ) + CALL CHKXER( 'STPLQT2', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL STPLQT2( 2, 2, 0, A, 1, B, 2, T, 2, INFO ) + CALL CHKXER( 'STPLQT2', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL STPLQT2( 2, 2, 0, A, 2, B, 1, T, 2, INFO ) + CALL CHKXER( 'STPLQT2', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL STPLQT2( 2, 2, 0, A, 2, B, 2, T, 1, INFO ) + CALL CHKXER( 'STPLQT2', INFOT, NOUT, LERR, OK ) +* +* STPMLQT +* + SRNAMT = 'STPMLQT' + INFOT = 1 + CALL STPMLQT( '/', 'N', 0, 0, 0, 0, 1, A, 1, T, 1, B, 1, C, 1, + $ W, INFO ) + CALL CHKXER( 'STPMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL STPMLQT( 'L', '/', 0, 0, 0, 0, 1, A, 1, T, 1, B, 1, C, 1, + $ W, INFO ) + CALL CHKXER( 'STPMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL STPMLQT( 'L', 'N', -1, 0, 0, 0, 1, A, 1, T, 1, B, 1, C, 1, + $ W, INFO ) + CALL CHKXER( 'STPMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL STPMLQT( 'L', 'N', 0, -1, 0, 0, 1, A, 1, T, 1, B, 1, C, 1, + $ W, INFO ) + CALL CHKXER( 'STPMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL STPMLQT( 'L', 'N', 0, 0, -1, 0, 1, A, 1, T, 1, B, 1, C, 1, + $ W, INFO ) + INFOT = 6 + CALL STPMLQT( 'L', 'N', 0, 0, 0, -1, 1, A, 1, T, 1, B, 1, C, 1, + $ W, INFO ) + CALL CHKXER( 'STPMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL STPMLQT( 'L', 'N', 0, 0, 0, 0, 0, A, 1, T, 1, B, 1, C, 1, + $ W, INFO ) + CALL CHKXER( 'STPMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL STPMLQT( 'R', 'N', 2, 2, 2, 1, 1, A, 1, T, 1, B, 1, C, 1, + $ W, INFO ) + CALL CHKXER( 'STPMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL STPMLQT( 'R', 'N', 1, 1, 1, 1, 1, A, 1, T, 0, B, 1, C, 1, + $ W, INFO ) + CALL CHKXER( 'STPMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 13 + CALL STPMLQT( 'L', 'N', 1, 1, 1, 1, 1, A, 1, T, 1, B, 0, C, 1, + $ W, INFO ) + CALL CHKXER( 'STPMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 15 + CALL STPMLQT( 'L', 'N', 1, 1, 1, 1, 1, A, 1, T, 1, B, 1, C, 0, + $ W, INFO ) + CALL CHKXER( 'STPMLQT', INFOT, NOUT, LERR, OK ) +* +* Print a summary line. +* + CALL ALAESM( PATH, OK, NOUT ) +* + RETURN +* +* End of SERRLQT +* + END diff --git a/TESTING/LIN/serrtsqr.f b/TESTING/LIN/serrtsqr.f new file mode 100644 index 00000000..0ba37978 --- /dev/null +++ b/TESTING/LIN/serrtsqr.f @@ -0,0 +1,243 @@ +*> \brief \b DERRTSQR +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SERRTSQR( PATH, NUNIT ) +* +* .. Scalar Arguments .. +* CHARACTER*3 PATH +* INTEGER NUNIT +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DERRTSQR tests the error exits for the REAL routines +*> that use the TSQR decomposition of a general matrix. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] PATH +*> \verbatim +*> PATH is CHARACTER*3 +*> The LAPACK path name for the routines to be tested. +*> \endverbatim +*> +*> \param[in] NUNIT +*> \verbatim +*> NUNIT is INTEGER +*> The unit number for output. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2011 +* +*> \ingroup double_lin +* +* ===================================================================== + SUBROUTINE SERRTSQR( PATH, NUNIT ) + IMPLICIT NONE +* +* -- LAPACK test routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + CHARACTER*3 PATH + INTEGER NUNIT +* .. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER NMAX + PARAMETER ( NMAX = 2 ) +* .. +* .. Local Scalars .. + INTEGER I, INFO, J, NB +* .. +* .. Local Arrays .. + REAL A( NMAX, NMAX ), T( NMAX, NMAX ), W( NMAX ), + $ C( NMAX, NMAX ), TAU(NMAX) +* .. +* .. External Subroutines .. + EXTERNAL ALAESM, CHKXER, SGEQR, + $ SGEMQR, SGELQ, SGEMLQ +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, NOUT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NOUT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Intrinsic Functions .. + INTRINSIC REAL +* .. +* .. Executable Statements .. +* + NOUT = NUNIT + WRITE( NOUT, FMT = * ) +* +* Set the variables to innocuous values. +* + DO J = 1, NMAX + DO I = 1, NMAX + A( I, J ) = 1.D0 / REAL( I+J ) + C( I, J ) = 1.D0 / REAL( I+J ) + T( I, J ) = 1.D0 / REAL( I+J ) + END DO + W( J ) = 0.D0 + END DO + OK = .TRUE. +* +* Error exits for TS factorization +* +* SGEQR +* + SRNAMT = 'SGEQR' + INFOT = 1 + CALL SGEQR( -1, 0, A, 1, TAU, 1, W, 1, INFO ) + CALL CHKXER( 'SGEQR', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SGEQR( 0, -1, A, 1, TAU, 1, W, 1, INFO ) + CALL CHKXER( 'SGEQR', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SGEQR( 1, 1, A, 0, TAU, 1, W, 1, INFO ) + CALL CHKXER( 'SGEQR', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL SGEQR( 3, 2, A, 3, TAU, 1, W, 1, INFO ) + CALL CHKXER( 'SGEQR', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL SGEQR( 3, 2, A, 3, TAU, 7, W, 0, INFO ) + CALL CHKXER( 'SGEQR', INFOT, NOUT, LERR, OK ) +* +* SGEMQR +* + TAU(1)=1 + TAU(2)=1 + SRNAMT = 'SGEMQR' + NB=1 + INFOT = 1 + CALL SGEMQR( '/', 'N', 0, 0, 0, A, 1, TAU, 1, C, 1, W, 1,INFO) + CALL CHKXER( 'SGEMQR', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SGEMQR( 'L', '/', 0, 0, 0, A, 1, TAU, 1, C, 1, W, 1,INFO) + CALL CHKXER( 'SGEMQR', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL SGEMQR( 'L', 'N', -1, 0, 0, A, 1, TAU, 1, C, 1, W,1,INFO) + CALL CHKXER( 'SGEMQR', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SGEMQR( 'L', 'N', 0, -1, 0, A, 1, TAU, 1, C, 1, W,1,INFO) + CALL CHKXER( 'SGEMQR', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL SGEMQR( 'L', 'N', 0, 0, -1, A, 1, TAU, 1, C, 1, W,1,INFO) + CALL CHKXER( 'SGEMQR', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL SGEMQR( 'R', 'N', 0, 0, -1, A, 1, TAU, 1, C, 1, W,1,INFO) + CALL CHKXER( 'SGEMQR', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL SGEMQR( 'L', 'N', 2, 1, 0, A, 0, TAU, 1, C, 1, W, 1,INFO) + CALL CHKXER( 'SGEMQR', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL SGEMQR( 'R', 'N', 2, 2, 1, A, 1, TAU, 0, C, 1, W, 1,INFO) + CALL CHKXER( 'SGEMQR', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL SGEMQR( 'L', 'N', 2, 2, 1, A, 1, TAU, 0, C, 1, W, 1,INFO) + CALL CHKXER( 'SGEMQR', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL SGEMQR( 'L', 'N', 2, 1, 1, A, 1, TAU, 6, C, 0, W, 1,INFO) + CALL CHKXER( 'SGEMQR', INFOT, NOUT, LERR, OK ) + INFOT = 13 + CALL SGEMQR( 'L', 'N', 2, 2, 1, A, 2, TAU, 6, C, 2, W, 0,INFO) + CALL CHKXER( 'SGEMQR', INFOT, NOUT, LERR, OK ) +* +* SGELQ +* + SRNAMT = 'SGELQ' + INFOT = 1 + CALL SGELQ( -1, 0, A, 1, TAU, 1, W, 1, INFO ) + CALL CHKXER( 'SGELQ', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SGELQ( 0, -1, A, 1, TAU, 1, W, 1, INFO ) + CALL CHKXER( 'SGELQ', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SGELQ( 1, 1, A, 0, TAU, 1, W, 1, INFO ) + CALL CHKXER( 'SGELQ', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL SGELQ( 2, 3, A, 3, TAU, 1, W, 1, INFO ) + CALL CHKXER( 'SGELQ', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL SGELQ( 2, 3, A, 3, TAU, 7, W, 0, INFO ) + CALL CHKXER( 'SGELQ', INFOT, NOUT, LERR, OK ) +* +* SGEMLQ +* + TAU(1)=1 + TAU(2)=1 + SRNAMT = 'SGEMLQ' + NB=1 + INFOT = 1 + CALL SGEMLQ( '/', 'N', 0, 0, 0, A, 1, TAU, 1, C, 1, W, 1,INFO) + CALL CHKXER( 'SGEMLQ', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SGEMLQ( 'L', '/', 0, 0, 0, A, 1, TAU, 1, C, 1, W, 1,INFO) + CALL CHKXER( 'SGEMLQ', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL SGEMLQ( 'L', 'N', -1, 0, 0, A, 1, TAU, 1, C, 1, W,1,INFO) + CALL CHKXER( 'SGEMLQ', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SGEMLQ( 'L', 'N', 0, -1, 0, A, 1, TAU, 1, C, 1, W,1,INFO) + CALL CHKXER( 'SGEMLQ', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL SGEMLQ( 'L', 'N', 0, 0, -1, A, 1, TAU, 1, C, 1, W,1,INFO) + CALL CHKXER( 'SGEMLQ', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL SGEMLQ( 'R', 'N', 0, 0, -1, A, 1, TAU, 1, C, 1, W,1,INFO) + CALL CHKXER( 'SGEMLQ', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL SGEMLQ( 'L', 'N', 1, 2, 0, A, 0, TAU, 1, C, 1, W, 1,INFO) + CALL CHKXER( 'SGEMLQ', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL SGEMLQ( 'R', 'N', 2, 2, 1, A, 1, TAU, 0, C, 1, W, 1,INFO) + CALL CHKXER( 'SGEMLQ', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL SGEMLQ( 'L', 'N', 2, 2, 1, A, 1, TAU, 0, C, 1, W, 1,INFO) + CALL CHKXER( 'SGEMLQ', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL SGEMLQ( 'L', 'N', 1, 2, 1, A, 1, TAU, 6, C, 0, W, 1,INFO) + CALL CHKXER( 'SGEMLQ', INFOT, NOUT, LERR, OK ) + INFOT = 13 + CALL SGEMLQ( 'L', 'N', 2, 2, 1, A, 2, TAU, 6, C, 2, W, 0,INFO) + CALL CHKXER( 'SGEMLQ', INFOT, NOUT, LERR, OK ) +* +* Print a summary line. +* + CALL ALAESM( PATH, OK, NOUT ) +* + RETURN +* +* End of SERRTSQR +* + END diff --git a/TESTING/LIN/slqt04.f b/TESTING/LIN/slqt04.f new file mode 100644 index 00000000..debae5ca --- /dev/null +++ b/TESTING/LIN/slqt04.f @@ -0,0 +1,259 @@ +*> \brief \b SLQT04 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SLQT04(M,N,NB,RESULT) +* +* .. Scalar Arguments .. +* INTEGER M, N, NB, LDT +* .. Return values .. +* REAL RESULT(6) +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SLQT04 tests SGELQT and SGEMLQT. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> Number of rows in test matrix. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> Number of columns in test matrix. +*> \endverbatim +*> +*> \param[in] NB +*> \verbatim +*> NB is INTEGER +*> Block size of test matrix. NB <= Min(M,N). +*> \endverbatim +*> +*> \param[out] RESULT +*> \verbatim +*> RESULT is REAL array, dimension (6) +*> Results of each of the six tests below. +*> +*> RESULT(1) = | A - L Q | +*> RESULT(2) = | I - Q Q^H | +*> RESULT(3) = | Q C - Q C | +*> RESULT(4) = | Q^H C - Q^H C | +*> RESULT(5) = | C Q - C Q | +*> RESULT(6) = | C Q^H - C Q^H | +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date April 2012 +* +*> \ingroup double_lin +* +* ===================================================================== + SUBROUTINE SLQT04(M,N,NB,RESULT) + IMPLICIT NONE +* +* -- LAPACK test routine (version 3.4.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* April 2012 +* +* .. Scalar Arguments .. + INTEGER M, N, NB, LDT +* .. Return values .. + REAL RESULT(6) +* +* ===================================================================== +* +* .. +* .. Local allocatable arrays + REAL, ALLOCATABLE :: AF(:,:), Q(:,:), + $ L(:,:), RWORK(:), WORK( : ), T(:,:), + $ CF(:,:), DF(:,:), A(:,:), C(:,:), D(:,:) +* +* .. Parameters .. + REAL ONE, ZERO + PARAMETER( ZERO = 0.0, ONE = 1.0 ) +* .. +* .. Local Scalars .. + INTEGER INFO, J, K, LL, LWORK + REAL ANORM, EPS, RESID, CNORM, DNORM +* .. +* .. Local Arrays .. + INTEGER ISEED( 4 ) +* .. +* .. External Functions .. + REAL SLAMCH, SLANGE, SLANSY + LOGICAL LSAME + EXTERNAL SLAMCH, SLANGE, SLANSY, LSAME +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Data statements .. + DATA ISEED / 1988, 1989, 1990, 1991 / +* + EPS = SLAMCH( 'Epsilon' ) + K = MIN(M,N) + LL = MAX(M,N) + LWORK = MAX(2,LL)*MAX(2,LL)*NB +* +* Dynamically allocate local arrays +* + ALLOCATE ( A(M,N), AF(M,N), Q(N,N), L(LL,N), RWORK(LL), + $ WORK(LWORK), T(NB,N), C(M,N), CF(M,N), + $ D(N,M), DF(N,M) ) +* +* Put random numbers into A and copy to AF +* + LDT=NB + DO J=1,N + CALL SLARNV( 2, ISEED, M, A( 1, J ) ) + END DO + CALL SLACPY( 'Full', M, N, A, M, AF, M ) +* +* Factor the matrix A in the array AF. +* + CALL SGELQT( M, N, NB, AF, M, T, LDT, WORK, INFO ) +* +* Generate the n-by-n matrix Q +* + CALL SLASET( 'Full', N, N, ZERO, ONE, Q, N ) + CALL SGEMLQT( 'R', 'N', N, N, K, NB, AF, M, T, LDT, Q, N, + $ WORK, INFO ) +* +* Copy R +* + CALL SLASET( 'Full', M, N, ZERO, ZERO, L, LL ) + CALL SLACPY( 'Lower', M, N, AF, M, L, LL ) +* +* Compute |L - A*Q'| / |A| and store in RESULT(1) +* + CALL SGEMM( 'N', 'T', M, N, N, -ONE, A, M, Q, N, ONE, L, LL ) + ANORM = SLANGE( '1', M, N, A, M, RWORK ) + RESID = SLANGE( '1', M, N, L, LL, RWORK ) + IF( ANORM.GT.ZERO ) THEN + RESULT( 1 ) = RESID / (EPS*MAX(1,M)*ANORM) + ELSE + RESULT( 1 ) = ZERO + END IF +* +* Compute |I - Q'*Q| and store in RESULT(2) +* + CALL SLASET( 'Full', N, N, ZERO, ONE, L, LL ) + CALL SSYRK( 'U', 'C', N, N, -ONE, Q, N, ONE, L, LL ) + RESID = SLANSY( '1', 'Upper', N, L, LL, RWORK ) + RESULT( 2 ) = RESID / (EPS*MAX(1,N)) +* +* Generate random m-by-n matrix C and a copy CF +* + DO J=1,M + CALL SLARNV( 2, ISEED, N, D( 1, J ) ) + END DO + DNORM = SLANGE( '1', N, M, D, N, RWORK) + CALL SLACPY( 'Full', N, M, D, N, DF, N ) +* +* Apply Q to C as Q*C +* + CALL SGEMLQT( 'L', 'N', N, M, K, NB, AF, M, T, NB, DF, N, + $ WORK, INFO) +* +* Compute |Q*D - Q*D| / |D| +* + CALL SGEMM( 'N', 'N', N, M, N, -ONE, Q, N, D, N, ONE, DF, N ) + RESID = SLANGE( '1', N, M, DF, N, RWORK ) + IF( DNORM.GT.ZERO ) THEN + RESULT( 3 ) = RESID / (EPS*MAX(1,M)*DNORM) + ELSE + RESULT( 3 ) = ZERO + END IF +* +* Copy D into DF again +* + CALL SLACPY( 'Full', N, M, D, N, DF, N ) +* +* Apply Q to D as QT*D +* + CALL SGEMLQT( 'L', 'T', N, M, K, NB, AF, M, T, NB, DF, N, + $ WORK, INFO) +* +* Compute |QT*D - QT*D| / |D| +* + CALL SGEMM( 'T', 'N', N, M, N, -ONE, Q, N, D, N, ONE, DF, N ) + RESID = SLANGE( '1', N, M, DF, N, RWORK ) + IF( DNORM.GT.ZERO ) THEN + RESULT( 4 ) = RESID / (EPS*MAX(1,M)*DNORM) + ELSE + RESULT( 4 ) = ZERO + END IF +* +* Generate random n-by-m matrix D and a copy DF +* + DO J=1,N + CALL SLARNV( 2, ISEED, M, C( 1, J ) ) + END DO + CNORM = SLANGE( '1', M, N, C, M, RWORK) + CALL SLACPY( 'Full', M, N, C, M, CF, M ) +* +* Apply Q to C as C*Q +* + CALL SGEMLQT( 'R', 'N', M, N, K, NB, AF, M, T, NB, CF, M, + $ WORK, INFO) +* +* Compute |C*Q - C*Q| / |C| +* + CALL SGEMM( 'N', 'N', M, N, N, -ONE, C, M, Q, N, ONE, CF, M ) + RESID = SLANGE( '1', N, M, DF, N, RWORK ) + IF( CNORM.GT.ZERO ) THEN + RESULT( 5 ) = RESID / (EPS*MAX(1,M)*DNORM) + ELSE + RESULT( 5 ) = ZERO + END IF +* +* Copy C into CF again +* + CALL SLACPY( 'Full', M, N, C, M, CF, M ) +* +* Apply Q to D as D*QT +* + CALL SGEMLQT( 'R', 'T', M, N, K, NB, AF, M, T, NB, CF, M, + $ WORK, INFO) +* +* Compute |C*QT - C*QT| / |C| +* + CALL SGEMM( 'N', 'T', M, N, N, -ONE, C, M, Q, N, ONE, CF, M ) + RESID = SLANGE( '1', M, N, CF, M, RWORK ) + IF( CNORM.GT.ZERO ) THEN + RESULT( 6 ) = RESID / (EPS*MAX(1,M)*DNORM) + ELSE + RESULT( 6 ) = ZERO + END IF +* +* Deallocate all arrays +* + DEALLOCATE ( A, AF, Q, L, RWORK, WORK, T, C, D, CF, DF) +* + RETURN + END + diff --git a/TESTING/LIN/slqt05.f b/TESTING/LIN/slqt05.f new file mode 100644 index 00000000..5ad3a4b2 --- /dev/null +++ b/TESTING/LIN/slqt05.f @@ -0,0 +1,279 @@ +* Definition: +* =========== +* +* SUBROUTINE SLQT05(M,N,L,NB,RESULT) +* +* .. Scalar Arguments .. +* INTEGER LWORK, M, N, L, NB, LDT +* .. Return values .. +* REAL RESULT(6) +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SQRT05 tests STPLQT and STPMLQT. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> Number of rows in lower part of the test matrix. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> Number of columns in test matrix. +*> \endverbatim +*> +*> \param[in] L +*> \verbatim +*> L is INTEGER +*> The number of rows of the upper trapezoidal part the +*> lower test matrix. 0 <= L <= M. +*> \endverbatim +*> +*> \param[in] NB +*> \verbatim +*> NB is INTEGER +*> Block size of test matrix. NB <= N. +*> \endverbatim +*> +*> \param[out] RESULT +*> \verbatim +*> RESULT is REAL array, dimension (6) +*> Results of each of the six tests below. +*> +*> RESULT(1) = | A - Q R | +*> RESULT(2) = | I - Q^H Q | +*> RESULT(3) = | Q C - Q C | +*> RESULT(4) = | Q^H C - Q^H C | +*> RESULT(5) = | C Q - C Q | +*> RESULT(6) = | C Q^H - C Q^H | +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date April 2012 +* +*> \ingroup double_lin +* +* ===================================================================== + SUBROUTINE SLQT05(M,N,L,NB,RESULT) + IMPLICIT NONE +* +* -- LAPACK test routine (version 3.4.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* April 2012 +* +* .. Scalar Arguments .. + INTEGER LWORK, M, N, L, NB, LDT +* .. Return values .. + REAL RESULT(6) +* +* ===================================================================== +* +* .. +* .. Local allocatable arrays + REAL, ALLOCATABLE :: AF(:,:), Q(:,:), + $ R(:,:), RWORK(:), WORK( : ), T(:,:), + $ CF(:,:), DF(:,:), A(:,:), C(:,:), D(:,:) +* +* .. Parameters .. + REAL ONE, ZERO + PARAMETER( ZERO = 0.0, ONE = 1.0 ) +* .. +* .. Local Scalars .. + INTEGER INFO, J, K, N2, NP1,i + REAL ANORM, EPS, RESID, CNORM, DNORM +* .. +* .. Local Arrays .. + INTEGER ISEED( 4 ) +* .. +* .. External Functions .. + REAL SLAMCH, SLANGE, SLANSY + LOGICAL LSAME + EXTERNAL SLAMCH, SLANGE, SLANSY, LSAME +* .. +* .. Data statements .. + DATA ISEED / 1988, 1989, 1990, 1991 / +* + EPS = SLAMCH( 'Epsilon' ) + K = M + N2 = M+N + IF( N.GT.0 ) THEN + NP1 = M+1 + ELSE + NP1 = 1 + END IF + LWORK = N2*N2*NB +* +* Dynamically allocate all arrays +* + ALLOCATE(A(M,N2),AF(M,N2),Q(N2,N2),R(N2,N2),RWORK(N2), + $ WORK(LWORK),T(NB,M),C(N2,M),CF(N2,M), + $ D(M,N2),DF(M,N2) ) +* +* Put random stuff into A +* + LDT=NB + CALL SLASET( 'Full', M, N2, ZERO, ZERO, A, M ) + CALL SLASET( 'Full', NB, M, ZERO, ZERO, T, NB ) + DO J=1,M + CALL SLARNV( 2, ISEED, M-J+1, A( J, J ) ) + END DO + IF( N.GT.0 ) THEN + DO J=1,N-L + CALL SLARNV( 2, ISEED, M, A( 1, MIN(N+M,M+1) + J - 1 ) ) + END DO + END IF + IF( L.GT.0 ) THEN + DO J=1,L + CALL SLARNV( 2, ISEED, M-J+1, A( J, MIN(N+M,N+M-L+1) + $ + J - 1 ) ) + END DO + END IF +* +* Copy the matrix A to the array AF. +* + CALL SLACPY( 'Full', M, N2, A, M, AF, M ) +* +* Factor the matrix A in the array AF. +* + CALL STPLQT( M,N,L,NB,AF,M,AF(1,NP1),M,T,LDT,WORK,INFO) +* +* Generate the (M+N)-by-(M+N) matrix Q by applying H to I +* + CALL SLASET( 'Full', N2, N2, ZERO, ONE, Q, N2 ) + CALL SGEMLQT( 'L', 'N', N2, N2, K, NB, AF, M, T, LDT, Q, N2, + $ WORK, INFO ) +* +* Copy L +* + CALL SLASET( 'Full', N2, N2, ZERO, ZERO, R, N2 ) + CALL SLACPY( 'Lower', M, N2, AF, M, R, N2 ) +* +* Compute |L - A*Q*T| / |A| and store in RESULT(1) +* + CALL SGEMM( 'N', 'T', M, N2, N2, -ONE, A, M, Q, N2, ONE, R, N2) + ANORM = SLANGE( '1', M, N2, A, M, RWORK ) + RESID = SLANGE( '1', M, N2, R, N2, RWORK ) + IF( ANORM.GT.ZERO ) THEN + RESULT( 1 ) = RESID / (EPS*ANORM*MAX(1,N2)) + ELSE + RESULT( 1 ) = ZERO + END IF +* +* Compute |I - Q*Q'| and store in RESULT(2) +* + CALL SLASET( 'Full', N2, N2, ZERO, ONE, R, N2 ) + CALL SSYRK( 'U', 'N', N2, N2, -ONE, Q, N2, ONE, R, N2 ) + RESID = SLANSY( '1', 'Upper', N2, R, N2, RWORK ) + RESULT( 2 ) = RESID / (EPS*MAX(1,N2)) +* +* Generate random m-by-n matrix C and a copy CF +* + CALL SLASET( 'Full', N2, M, ZERO, ONE, C, N2 ) + DO J=1,M + CALL SLARNV( 2, ISEED, N2, C( 1, J ) ) + END DO + CNORM = SLANGE( '1', N2, M, C, N2, RWORK) + CALL SLACPY( 'Full', N2, M, C, N2, CF, N2 ) +* +* Apply Q to C as Q*C +* + CALL STPMLQT( 'L','N', N,M,K,L,NB,AF(1, NP1),M,T,LDT,CF,N2, + $ CF(NP1,1),N2,WORK,INFO) +* +* Compute |Q*C - Q*C| / |C| +* + CALL SGEMM( 'N', 'N', N2, M, N2, -ONE, Q, N2, C, N2, ONE, CF, N2 ) + RESID = SLANGE( '1', N2, M, CF, N2, RWORK ) + IF( CNORM.GT.ZERO ) THEN + RESULT( 3 ) = RESID / (EPS*MAX(1,N2)*CNORM) + ELSE + RESULT( 3 ) = ZERO + END IF + +* +* Copy C into CF again +* + CALL SLACPY( 'Full', N2, M, C, N2, CF, N2 ) +* +* Apply Q to C as QT*C +* + CALL STPMLQT( 'L','T',N,M,K,L,NB,AF(1,NP1),M,T,LDT,CF,N2, + $ CF(NP1,1),N2,WORK,INFO) +* +* Compute |QT*C - QT*C| / |C| +* + CALL SGEMM('T','N',N2,M,N2,-ONE,Q,N2,C,N2,ONE,CF,N2) + RESID = SLANGE( '1', N2, M, CF, N2, RWORK ) + + IF( CNORM.GT.ZERO ) THEN + RESULT( 4 ) = RESID / (EPS*MAX(1,N2)*CNORM) + ELSE + RESULT( 4 ) = ZERO + END IF +* +* Generate random m-by-n matrix D and a copy DF +* + DO J=1,N2 + CALL SLARNV( 2, ISEED, M, D( 1, J ) ) + END DO + DNORM = SLANGE( '1', M, N2, D, M, RWORK) + CALL SLACPY( 'Full', M, N2, D, M, DF, M ) +* +* Apply Q to D as D*Q +* + CALL STPMLQT('R','N',M,N,K,L,NB,AF(1,NP1),M,T,LDT,DF,M, + $ DF(1,NP1),M,WORK,INFO) +* +* Compute |D*Q - D*Q| / |D| +* + CALL SGEMM('N','N',M,N2,N2,-ONE,D,M,Q,N2,ONE,DF,M) + RESID = SLANGE('1',M, N2,DF,M,RWORK ) + IF( CNORM.GT.ZERO ) THEN + RESULT( 5 ) = RESID / (EPS*MAX(1,N2)*DNORM) + ELSE + RESULT( 5 ) = ZERO + END IF +* +* Copy D into DF again +* + CALL SLACPY('Full',M,N2,D,M,DF,M ) +* +* Apply Q to D as D*QT +* + CALL STPMLQT('R','T',M,N,K,L,NB,AF(1,NP1),M,T,LDT,DF,M, + $ DF(1,NP1),M,WORK,INFO) + +* +* Compute |D*QT - D*QT| / |D| +* + CALL SGEMM( 'N', 'T', M, N2, N2, -ONE, D, M, Q, N2, ONE, DF, M ) + RESID = SLANGE( '1', M, N2, DF, M, RWORK ) + IF( CNORM.GT.ZERO ) THEN + RESULT( 6 ) = RESID / (EPS*MAX(1,N2)*DNORM) + ELSE + RESULT( 6 ) = ZERO + END IF +* +* Deallocate all arrays +* + DEALLOCATE ( A, AF, Q, R, RWORK, WORK, T, C, D, CF, DF) + RETURN + END
\ No newline at end of file diff --git a/TESTING/LIN/stplqt.f b/TESTING/LIN/stplqt.f new file mode 100644 index 00000000..adbbfe8b --- /dev/null +++ b/TESTING/LIN/stplqt.f @@ -0,0 +1,253 @@ +* Definition: +* =========== +* +* SUBROUTINE STPLQT( M, N, L, MB, A, LDA, B, LDB, T, LDT, WORK, +* INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, LDB, LDT, N, M, L, MB +* .. +* .. Array Arguments .. +* REAL A( LDA, * ), B( LDB, * ), T( LDT, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> STPLQT computes a blocked LQ factorization of a real +*> "triangular-pentagonal" matrix C, which is composed of a +*> triangular block A and pentagonal block B, using the compact +*> WY representation for Q. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix B, and the order of the +*> triangular matrix A. +*> M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix B. +*> N >= 0. +*> \endverbatim +*> +*> \param[in] L +*> \verbatim +*> L is INTEGER +*> The number of rows of the lower trapezoidal part of B. +*> MIN(M,N) >= L >= 0. See Further Details. +*> \endverbatim +*> +*> \param[in] MB +*> \verbatim +*> MB is INTEGER +*> The block size to be used in the blocked QR. M >= MB >= 1. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is REAL array, dimension (LDA,N) +*> On entry, the lower triangular N-by-N matrix A. +*> On exit, the elements on and below the diagonal of the array +*> contain the lower triangular matrix L. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is REAL array, dimension (LDB,N) +*> On entry, the pentagonal M-by-N matrix B. The first N-L columns +*> are rectangular, and the last L columns are lower trapezoidal. +*> On exit, B contains the pentagonal matrix V. See Further Details. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,M). +*> \endverbatim +*> +*> \param[out] T +*> \verbatim +*> T is REAL array, dimension (LDT,N) +*> The lower triangular block reflectors stored in compact form +*> as a sequence of upper triangular blocks. See Further Details. +*> \endverbatim +*> +*> \param[in] LDT +*> \verbatim +*> LDT is INTEGER +*> The leading dimension of the array T. LDT >= MB. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is REAL array, dimension (MB*M) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2013 +* +*> \ingroup doubleOTHERcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The input matrix C is a M-by-(M+N) matrix +*> +*> C = [ A ] [ B ] +*> +*> +*> where A is an lower triangular N-by-N matrix, and B is M-by-N pentagonal +*> matrix consisting of a M-by-(N-L) rectangular matrix B1 on left of a M-by-L +*> upper trapezoidal matrix B2: +*> [ B ] = [ B1 ] [ B2 ] +*> [ B1 ] <- M-by-(N-L) rectangular +*> [ B2 ] <- M-by-L upper trapezoidal. +*> +*> The lower trapezoidal matrix B2 consists of the first L columns of a +*> N-by-N lower triangular matrix, where 0 <= L <= MIN(M,N). If L=0, +*> B is rectangular M-by-N; if M=L=N, B is lower triangular. +*> +*> The matrix W stores the elementary reflectors H(i) in the i-th row +*> above the diagonal (of A) in the M-by-(M+N) input matrix C +*> [ C ] = [ A ] [ B ] +*> [ A ] <- lower triangular N-by-N +*> [ B ] <- M-by-N pentagonal +*> +*> so that W can be represented as +*> [ W ] = [ I ] [ V ] +*> [ I ] <- identity, N-by-N +*> [ V ] <- M-by-N, same form as B. +*> +*> Thus, all of information needed for W is contained on exit in B, which +*> we call V above. Note that V has the same form as B; that is, +*> [ V ] = [ V1 ] [ V2 ] +*> [ V1 ] <- M-by-(N-L) rectangular +*> [ V2 ] <- M-by-L lower trapezoidal. +*> +*> The rows of V represent the vectors which define the H(i)'s. +*> +*> The number of blocks is B = ceiling(M/MB), where each +*> block is of order MB except for the last block, which is of order +*> IB = M - (M-1)*MB. For each of the B blocks, a upper triangular block +*> reflector factor is computed: T1, T2, ..., TB. The MB-by-MB (and IB-by-IB +*> for the last block) T's are stored in the MB-by-N matrix T as +*> +*> T = [T1 T2 ... TB]. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE STPLQT( M, N, L, MB, A, LDA, B, LDB, T, LDT, WORK, + $ INFO ) +* +* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2013 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, LDB, LDT, N, M, L, MB +* .. +* .. Array Arguments .. + REAL A( LDA, * ), B( LDB, * ), T( LDT, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. +* .. Local Scalars .. + INTEGER I, IB, LB, NB, IINFO +* .. +* .. External Subroutines .. + EXTERNAL STPLQT2, STPRFB, XERBLA +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( L.LT.0 .OR. (L.GT.MIN(M,N) .AND. MIN(M,N).GE.0)) THEN + INFO = -3 + ELSE IF( MB.LT.1 .OR. (MB.GT.M .AND. M.GT.0)) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -6 + ELSE IF( LDB.LT.MAX( 1, M ) ) THEN + INFO = -8 + ELSE IF( LDT.LT.MB ) THEN + INFO = -10 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'STPLQT', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.0 .OR. N.EQ.0 ) RETURN +* + DO I = 1, M, MB +* +* Compute the QR factorization of the current block +* + IB = MIN( M-I+1, MB ) + NB = MIN( N-L+I+IB-1, N ) + IF( I.GE.L ) THEN + LB = 0 + ELSE + LB = NB-N+L-I+1 + END IF +* + CALL STPLQT2( IB, NB, LB, A(I,I), LDA, B( I, 1 ), LDB, + $ T(1, I ), LDT, IINFO ) +* +* Update by applying H**T to B(I+IB:M,:) from the right +* + IF( I+IB.LE.M ) THEN + CALL STPRFB( 'R', 'N', 'F', 'R', M-I-IB+1, NB, IB, LB, + $ B( I, 1 ), LDB, T( 1, I ), LDT, + $ A( I+IB, I ), LDA, B( I+IB, 1 ), LDB, + $ WORK, M-I-IB+1) + END IF + END DO + RETURN +* +* End of STPLQT +* + END diff --git a/TESTING/LIN/stsqr01.f b/TESTING/LIN/stsqr01.f new file mode 100644 index 00000000..dbaf3aac --- /dev/null +++ b/TESTING/LIN/stsqr01.f @@ -0,0 +1,428 @@ +*> \brief \b STSQR01 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE STSQR01(TSSW, M,N, MB, NB, RESULT) +* +* .. Scalar Arguments .. +* INTEGER M, N, MB +* .. Return values .. +* REAL RESULT(6) +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DTSQR01 tests DGEQR , DGELQ, DGEMLQ and DGEMQR. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] TSSW +*> \verbatim +*> TSSW is CHARACTER +*> 'TS' for testing tall skinny QR +*> and anything else for testing short wide LQ +*> \endverbatim +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> Number of rows in test matrix. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> Number of columns in test matrix. +*> \endverbatim +*> \param[in] MB +*> \verbatim +*> MB is INTEGER +*> Number of row in row block in test matrix. +*> \endverbatim +*> +*> \param[in] NB +*> \verbatim +*> NB is INTEGER +*> Number of columns in column block test matrix. +*> \endverbatim +*> +*> \param[out] RESULT +*> \verbatim +*> RESULT is REAL array, dimension (6) +*> Results of each of the six tests below. +*> +*> RESULT(1) = | A - Q R | or | A - L Q | +*> RESULT(2) = | I - Q^H Q | or | I - Q Q^H | +*> RESULT(3) = | Q C - Q C | +*> RESULT(4) = | Q^H C - Q^H C | +*> RESULT(5) = | C Q - C Q | +*> RESULT(6) = | C Q^H - C Q^H | +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date April 2012 +* +*> \ingroup double_lin +* +* ===================================================================== + SUBROUTINE STSQR01(TSSW, M, N, MB, NB, RESULT) + IMPLICIT NONE +* +* -- LAPACK test routine (version 3.4.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* April 2012 +* +* .. Scalar Arguments .. + CHARACTER TSSW + INTEGER M, N, MB, NB +* .. Return values .. + REAL RESULT(6) +* +* ===================================================================== +* +* .. +* .. Local allocatable arrays + REAL, ALLOCATABLE :: AF(:,:), Q(:,:), + $ R(:,:), RWORK(:), WORK( : ), T(:), + $ CF(:,:), DF(:,:), A(:,:), C(:,:), D(:,:), LQ(:,:) +* +* .. Parameters .. + REAL ONE, ZERO + PARAMETER( ZERO = 0.0, ONE = 1.0 ) +* .. +* .. Local Scalars .. + LOGICAL TESTZEROS, TS + INTEGER INFO, J, K, L, LWORK, LT ,MNB + REAL ANORM, EPS, RESID, CNORM, DNORM +* .. +* .. Local Arrays .. + INTEGER ISEED( 4 ) +* .. +* .. External Functions .. + REAL SLAMCH, SLANGE, SLANSY + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL SLAMCH, SLARNV, SLANGE, SLANSY, LSAME, ILAENV +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. Scalars in Common .. + CHARACTER*32 srnamt +* .. +* .. Common blocks .. + COMMON / srnamc / srnamt +* .. +* .. Data statements .. + DATA ISEED / 1988, 1989, 1990, 1991 / +* +* TEST TALL SKINNY OR SHORT WIDE +* + TS = LSAME(TSSW, 'TS') +* +* TEST MATRICES WITH HALF OF MATRIX BEING ZEROS +* + TESTZEROS = .FALSE. +* + EPS = SLAMCH( 'Epsilon' ) + K = MIN(M,N) + L = MAX(M,N,1) + MNB = MAX ( MB, NB) + LWORK = MAX(3,L)*MNB + IF((K.GE.MNB).OR.(MNB.GE.L))THEN + LT=MAX(1,L)*MNB+5 + ELSE + LT=MAX(1,(L-K)/(MNB-K)+1)*L*MNB+5 + END IF + +* +* Dynamically allocate local arrays +* + ALLOCATE ( A(M,N), AF(M,N), Q(L,L), R(M,L), RWORK(L), + $ WORK(LWORK), T(LT), C(M,N), CF(M,N), + $ D(N,M), DF(N,M), LQ(L,N) ) +* +* Put random numbers into A and copy to AF +* + DO J=1,N + CALL SLARNV( 2, ISEED, M, A( 1, J ) ) + END DO + IF (TESTZEROS) THEN + IF (M.GE.4) THEN + DO J=1,N + CALL SLARNV( 2, ISEED, M/2, A( M/4, J ) ) + END DO + END IF + END IF + CALL SLACPY( 'Full', M, N, A, M, AF, M ) +* + IF (TS) THEN +* +* Factor the matrix A in the array AF. +* + srnamt = 'SGEQR' + CALL SGEQR( M, N, AF, M, T, LT, WORK, LWORK, INFO ) +* +* Generate the m-by-m matrix Q +* + CALL SLASET( 'Full', M, M, ZERO, ONE, Q, M ) + srnamt = 'SGEMQR' + CALL SGEMQR( 'L', 'N', M, M, K, AF, M, T, LT, Q, M, + $ WORK, LWORK, INFO ) +* +* Copy R +* + CALL SLASET( 'Full', M, N, ZERO, ZERO, R, M ) + CALL SLACPY( 'Upper', M, N, AF, M, R, M ) +* +* Compute |R - Q'*A| / |A| and store in RESULT(1) +* + CALL SGEMM( 'T', 'N', M, N, M, -ONE, Q, M, A, M, ONE, R, M ) + ANORM = SLANGE( '1', M, N, A, M, RWORK ) + RESID = SLANGE( '1', M, N, R, M, RWORK ) + IF( ANORM.GT.ZERO ) THEN + RESULT( 1 ) = RESID / (EPS*MAX(1,M)*ANORM) + ELSE + RESULT( 1 ) = ZERO + END IF +* +* Compute |I - Q'*Q| and store in RESULT(2) +* + CALL SLASET( 'Full', M, M, ZERO, ONE, R, M ) + CALL SSYRK( 'U', 'C', M, M, -ONE, Q, M, ONE, R, M ) + RESID = SLANSY( '1', 'Upper', M, R, M, RWORK ) + RESULT( 2 ) = RESID / (EPS*MAX(1,M)) +* +* Generate random m-by-n matrix C and a copy CF +* + DO J=1,N + CALL SLARNV( 2, ISEED, M, C( 1, J ) ) + END DO + CNORM = SLANGE( '1', M, N, C, M, RWORK) + CALL SLACPY( 'Full', M, N, C, M, CF, M ) +* +* Apply Q to C as Q*C +* + srnamt = 'DGEQR' + CALL SGEMQR( 'L', 'N', M, N, K, AF, M, T, LT, CF, M, + $ WORK, LWORK, INFO) +* +* Compute |Q*C - Q*C| / |C| +* + CALL SGEMM( 'N', 'N', M, N, M, -ONE, Q, M, C, M, ONE, CF, M ) + RESID = SLANGE( '1', M, N, CF, M, RWORK ) + IF( CNORM.GT.ZERO ) THEN + RESULT( 3 ) = RESID / (EPS*MAX(1,M)*CNORM) + ELSE + RESULT( 3 ) = ZERO + END IF +* +* Copy C into CF again +* + CALL SLACPY( 'Full', M, N, C, M, CF, M ) +* +* Apply Q to C as QT*C +* + srnamt = 'DGEQR' + CALL SGEMQR( 'L', 'T', M, N, K, AF, M, T, LT, CF, M, + $ WORK, LWORK, INFO) +* +* Compute |QT*C - QT*C| / |C| +* + CALL SGEMM( 'T', 'N', M, N, M, -ONE, Q, M, C, M, ONE, CF, M ) + RESID = SLANGE( '1', M, N, CF, M, RWORK ) + IF( CNORM.GT.ZERO ) THEN + RESULT( 4 ) = RESID / (EPS*MAX(1,M)*CNORM) + ELSE + RESULT( 4 ) = ZERO + END IF +* +* Generate random n-by-m matrix D and a copy DF +* + DO J=1,M + CALL SLARNV( 2, ISEED, N, D( 1, J ) ) + END DO + DNORM = SLANGE( '1', N, M, D, N, RWORK) + CALL SLACPY( 'Full', N, M, D, N, DF, N ) +* +* Apply Q to D as D*Q +* + srnamt = 'DGEQR' + CALL SGEMQR( 'R', 'N', N, M, K, AF, M, T, LT, DF, N, + $ WORK, LWORK, INFO) +* +* Compute |D*Q - D*Q| / |D| +* + CALL SGEMM( 'N', 'N', N, M, M, -ONE, D, N, Q, M, ONE, DF, N ) + RESID = SLANGE( '1', N, M, DF, N, RWORK ) + IF( DNORM.GT.ZERO ) THEN + RESULT( 5 ) = RESID / (EPS*MAX(1,M)*DNORM) + ELSE + RESULT( 5 ) = ZERO + END IF +* +* Copy D into DF again +* + CALL SLACPY( 'Full', N, M, D, N, DF, N ) +* +* Apply Q to D as D*QT +* + CALL SGEMQR( 'R', 'T', N, M, K, AF, M, T, LT, DF, N, + $ WORK, LWORK, INFO) +* +* Compute |D*QT - D*QT| / |D| +* + CALL SGEMM( 'N', 'T', N, M, M, -ONE, D, N, Q, M, ONE, DF, N ) + RESID = SLANGE( '1', N, M, DF, N, RWORK ) + IF( CNORM.GT.ZERO ) THEN + RESULT( 6 ) = RESID / (EPS*MAX(1,M)*DNORM) + ELSE + RESULT( 6 ) = ZERO + END IF +* +* Short and wide +* + ELSE + srnamt = 'SGELQ' + CALL SGELQ( M, N, AF, M, T, LT, WORK, LWORK, INFO ) +* +* +* Generate the n-by-n matrix Q +* + CALL SLASET( 'Full', N, N, ZERO, ONE, Q, N ) + srnamt = 'SGEMQR' + CALL SGEMLQ( 'R', 'N', N, N, K, AF, M, T, LT, Q, N, + $ WORK, LWORK, INFO ) +* +* Copy R +* + CALL SLASET( 'Full', M, N, ZERO, ZERO, LQ, L ) + CALL SLACPY( 'Lower', M, N, AF, M, LQ, L ) +* +* Compute |L - A*Q'| / |A| and store in RESULT(1) +* + CALL SGEMM( 'N', 'T', M, N, N, -ONE, A, M, Q, N, ONE, LQ, L ) + ANORM = SLANGE( '1', M, N, A, M, RWORK ) + RESID = SLANGE( '1', M, N, LQ, L, RWORK ) + IF( ANORM.GT.ZERO ) THEN + RESULT( 1 ) = RESID / (EPS*MAX(1,N)*ANORM) + ELSE + RESULT( 1 ) = ZERO + END IF +* +* Compute |I - Q'*Q| and store in RESULT(2) +* + CALL SLASET( 'Full', N, N, ZERO, ONE, LQ, L ) + CALL SSYRK( 'U', 'C', N, N, -ONE, Q, N, ONE, LQ, L ) + RESID = SLANSY( '1', 'Upper', N, LQ, L, RWORK ) + RESULT( 2 ) = RESID / (EPS*MAX(1,N)) +* +* Generate random m-by-n matrix C and a copy CF +* + DO J=1,M + CALL SLARNV( 2, ISEED, N, D( 1, J ) ) + END DO + DNORM = SLANGE( '1', N, M, D, N, RWORK) + CALL SLACPY( 'Full', N, M, D, N, DF, N ) +* +* Apply Q to C as Q*C +* + CALL SGEMLQ( 'L', 'N', N, M, K, AF, M, T, LT, DF, N, + $ WORK, LWORK, INFO) +* +* Compute |Q*D - Q*D| / |D| +* + CALL SGEMM( 'N', 'N', N, M, N, -ONE, Q, N, D, N, ONE, DF, N ) + RESID = SLANGE( '1', N, M, DF, N, RWORK ) + IF( DNORM.GT.ZERO ) THEN + RESULT( 3 ) = RESID / (EPS*MAX(1,N)*DNORM) + ELSE + RESULT( 3 ) = ZERO + END IF +* +* Copy D into DF again +* + CALL SLACPY( 'Full', N, M, D, N, DF, N ) +* +* Apply Q to D as QT*D +* + CALL SGEMLQ( 'L', 'T', N, M, K, AF, M, T, LT, DF, N, + $ WORK, LWORK, INFO) +* +* Compute |QT*D - QT*D| / |D| +* + CALL SGEMM( 'T', 'N', N, M, N, -ONE, Q, N, D, N, ONE, DF, N ) + RESID = SLANGE( '1', N, M, DF, N, RWORK ) + IF( DNORM.GT.ZERO ) THEN + RESULT( 4 ) = RESID / (EPS*MAX(1,N)*DNORM) + ELSE + RESULT( 4 ) = ZERO + END IF +* +* Generate random n-by-m matrix D and a copy DF +* + DO J=1,N + CALL SLARNV( 2, ISEED, M, C( 1, J ) ) + END DO + CNORM = SLANGE( '1', M, N, C, M, RWORK) + CALL SLACPY( 'Full', M, N, C, M, CF, M ) +* +* Apply Q to C as C*Q +* + CALL SGEMLQ( 'R', 'N', M, N, K, AF, M, T, LT, CF, M, + $ WORK, LWORK, INFO) +* +* Compute |C*Q - C*Q| / |C| +* + CALL SGEMM( 'N', 'N', M, N, N, -ONE, C, M, Q, N, ONE, CF, M ) + RESID = SLANGE( '1', N, M, DF, N, RWORK ) + IF( CNORM.GT.ZERO ) THEN + RESULT( 5 ) = RESID / (EPS*MAX(1,N)*CNORM) + ELSE + RESULT( 5 ) = ZERO + END IF +* +* Copy C into CF again +* + CALL SLACPY( 'Full', M, N, C, M, CF, M ) +* +* Apply Q to D as D*QT +* + CALL SGEMLQ( 'R', 'T', M, N, K, AF, M, T, LT, CF, M, + $ WORK, LWORK, INFO) +* +* Compute |C*QT - C*QT| / |C| +* + CALL SGEMM( 'N', 'T', M, N, N, -ONE, C, M, Q, N, ONE, CF, M ) + RESID = SLANGE( '1', M, N, CF, M, RWORK ) + IF( CNORM.GT.ZERO ) THEN + RESULT( 6 ) = RESID / (EPS*MAX(1,N)*CNORM) + ELSE + RESULT( 6 ) = ZERO + END IF +* + END IF +* +* Deallocate all arrays +* + DEALLOCATE ( A, AF, Q, R, RWORK, WORK, T, C, D, CF, DF) +* + RETURN + END
\ No newline at end of file diff --git a/TESTING/LIN/zchkaa.f b/TESTING/LIN/zchkaa.f index 90b98a2e..2aae1a10 100644 --- a/TESTING/LIN/zchkaa.f +++ b/TESTING/LIN/zchkaa.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * PROGRAM ZCHKAA -* +* * *> \par Purpose: * ============= @@ -50,7 +50,6 @@ *> ZPB 8 List types on next line if 0 < NTYPES < 8 *> ZPT 12 List types on next line if 0 < NTYPES < 12 *> ZHE 10 List types on next line if 0 < NTYPES < 10 -*> ZHA 10 List types on next line if 0 < NTYPES < 10 *> ZHR 10 List types on next line if 0 < NTYPES < 10 *> ZHP 10 List types on next line if 0 < NTYPES < 10 *> ZSY 11 List types on next line if 0 < NTYPES < 11 @@ -69,6 +68,9 @@ *> ZEQ *> ZQT *> ZQX +*> ZTQ +*> ZXQ +*> ZTS *> \endverbatim * * Parameters: @@ -98,22 +100,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2016 +*> \date November 2015 * *> \ingroup complex16_lin * * ===================================================================== PROGRAM ZCHKAA * -* -- LAPACK test routine (version 3.7.0) -- +* -- LAPACK test routine (version 3.6.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2016 +* November 2015 * * ===================================================================== * @@ -166,7 +168,8 @@ $ ZCHKTB, ZCHKTP, ZCHKTR, ZCHKTZ, ZDRVGB, ZDRVGE, $ ZDRVGT, ZDRVHE, ZDRVHE_ROOK, ZDRVHP, ZDRVLS, $ ZDRVPB, ZDRVPO, ZDRVPP, ZDRVPT, ZDRVSP, ZDRVSY, - $ ZDRVSY_ROOK, ILAVER, ZCHKQRT, ZCHKQRTP + $ ZDRVSY_ROOK, ILAVER, ZCHKQRT, ZCHKQRTP, + $ ZCHKLQT, ZCHKLQTP, ZCHKTSQR * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -640,33 +643,6 @@ WRITE( NOUT, FMT = 9988 )PATH END IF * - ELSE IF( LSAMEN( 2, C2, 'HA' ) ) THEN -* -* HA: Hermitian indefinite matrices, -* with partial (Aasen's) pivoting algorithm -* - NTYPES = 10 - CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) -* - IF( TSTCHK ) THEN - CALL ZCHKHE_AASEN( DOTYPE, NN, NVAL, NNB2, NBVAL2, NNS, - $ NSVAL, THRESH, TSTERR, LDA, - $ A( 1, 1 ), A( 1, 2 ), A( 1, 3 ), - $ B( 1, 1 ), B( 1, 2 ), B( 1, 3 ), - $ WORK, RWORK, IWORK, NOUT ) - ELSE - WRITE( NOUT, FMT = 9989 )PATH - END IF -* - IF( TSTDRV ) THEN - CALL ZDRVHE_AASEN( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, - $ LDA, A( 1, 1 ), A( 1, 2 ), A( 1, 3 ), - $ B( 1, 1 ), B( 1, 2 ), B( 1, 3 ), - $ WORK, RWORK, IWORK, NOUT ) - ELSE - WRITE( NOUT, FMT = 9988 )PATH - END IF -* ELSE IF( LSAMEN( 2, C2, 'HR' ) ) THEN * * HR: Hermitian indefinite matrices, @@ -975,7 +951,7 @@ * QT: QRT routines for general matrices * IF( TSTCHK ) THEN - CALL ZCHKQRT( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, + CALL ZCHKQRT( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, $ NBVAL, NOUT ) ELSE WRITE( NOUT, FMT = 9989 )PATH @@ -986,7 +962,73 @@ * QX: QRT routines for triangular-pentagonal matrices * IF( TSTCHK ) THEN - CALL ZCHKQRTP( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, + CALL ZCHKQRTP( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, + $ NBVAL, NOUT ) + ELSE + WRITE( NOUT, FMT = 9989 )PATH + END IF +* + ELSE IF( LSAMEN( 2, C2, 'TQ' ) ) THEN +* +* TQ: LQT routines for general matrices +* + IF( TSTCHK ) THEN + CALL ZCHKLQT( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, + $ NBVAL, NOUT ) + ELSE + WRITE( NOUT, FMT = 9989 )PATH + END IF +* + ELSE IF( LSAMEN( 2, C2, 'XQ' ) ) THEN +* +* XQ: LQT routines for triangular-pentagonal matrices +* + IF( TSTCHK ) THEN + CALL ZCHKLQTP( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, + $ NBVAL, NOUT ) + ELSE + WRITE( NOUT, FMT = 9989 )PATH + END IF +* + ELSE IF( LSAMEN( 2, C2, 'TS' ) ) THEN +* +* TS: QR routines for tall-skinny matrices +* + IF( TSTCHK ) THEN + CALL ZCHKTSQR( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, + $ NBVAL, NOUT ) + ELSE + WRITE( NOUT, FMT = 9989 )PATH + END IF +* + ELSE IF( LSAMEN( 2, C2, 'TQ' ) ) THEN +* +* TQ: LQT routines for general matrices +* + IF( TSTCHK ) THEN + CALL ZCHKLQT( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, + $ NBVAL, NOUT ) + ELSE + WRITE( NOUT, FMT = 9989 )PATH + END IF +* + ELSE IF( LSAMEN( 2, C2, 'XQ' ) ) THEN +* +* XQ: LQT routines for triangular-pentagonal matrices +* + IF( TSTCHK ) THEN + CALL ZCHKLQTP( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, + $ NBVAL, NOUT ) + ELSE + WRITE( NOUT, FMT = 9989 )PATH + END IF +* + ELSE IF( LSAMEN( 2, C2, 'TS' ) ) THEN +* +* TS: QR routines for tall-skinny matrices +* + IF( TSTCHK ) THEN + CALL ZCHKTSQR( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, $ NBVAL, NOUT ) ELSE WRITE( NOUT, FMT = 9989 )PATH diff --git a/TESTING/LIN/zchklqt.f b/TESTING/LIN/zchklqt.f new file mode 100644 index 00000000..e15793be --- /dev/null +++ b/TESTING/LIN/zchklqt.f @@ -0,0 +1,210 @@ +*> \brief \b ZCHKLQT +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZCHKLQT( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, +* NBVAL, NOUT ) +* +* .. Scalar Arguments .. +* LOGICAL TSTERR +* INTEGER NM, NN, NNB, NOUT +* DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. +* INTEGER MVAL( * ), NBVAL( * ), NVAL( * ) +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZCHKLQT tests ZGELQT and ZUNMLQT. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] THRESH +*> \verbatim +*> THRESH is DOUBLE PRECISION +*> The threshold value for the test ratios. A result is +*> included in the output file if RESULT >= THRESH. To have +*> every test ratio printed, use THRESH = 0. +*> \endverbatim +*> +*> \param[in] TSTERR +*> \verbatim +*> TSTERR is LOGICAL +*> Flag that indicates whether error exits are to be tested. +*> \endverbatim +*> +*> \param[in] NM +*> \verbatim +*> NM is INTEGER +*> The number of values of M contained in the vector MVAL. +*> \endverbatim +*> +*> \param[in] MVAL +*> \verbatim +*> MVAL is INTEGER array, dimension (NM) +*> The values of the matrix row dimension M. +*> \endverbatim +*> +*> \param[in] NN +*> \verbatim +*> NN is INTEGER +*> The number of values of N contained in the vector NVAL. +*> \endverbatim +*> +*> \param[in] NVAL +*> \verbatim +*> NVAL is INTEGER array, dimension (NN) +*> The values of the matrix column dimension N. +*> \endverbatim +*> +*> \param[in] NNB +*> \verbatim +*> NNB is INTEGER +*> The number of values of NB contained in the vector NBVAL. +*> \endverbatim +*> +*> \param[in] NBVAL +*> \verbatim +*> NBVAL is INTEGER array, dimension (NBVAL) +*> The values of the blocksize NB. +*> \endverbatim +*> +*> \param[in] NOUT +*> \verbatim +*> NOUT is INTEGER +*> The unit number for output. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2011 +* +*> \ingroup double_lin +* +* ===================================================================== + SUBROUTINE ZCHKLQT( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, + $ NBVAL, NOUT ) + IMPLICIT NONE +* +* -- LAPACK test routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + LOGICAL TSTERR + INTEGER NM, NN, NNB, NOUT + DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. + INTEGER MVAL( * ), NBVAL( * ), NVAL( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER NTESTS + PARAMETER ( NTESTS = 6 ) +* .. +* .. Local Scalars .. + CHARACTER*3 PATH + INTEGER I, J, K, T, M, N, NB, NFAIL, NERRS, NRUN, + $ MINMN +* +* .. Local Arrays .. + DOUBLE PRECISION RESULT( NTESTS ) +* .. +* .. External Subroutines .. + EXTERNAL ALAERH, ALAHD, ALASUM, ZERRLQT, ZLQT04 +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, NUNIT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NUNIT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Executable Statements .. +* +* Initialize constants +* + PATH( 1: 1 ) = 'Z' + PATH( 2: 3 ) = 'TQ' + NRUN = 0 + NFAIL = 0 + NERRS = 0 +* +* Test the error exits +* + IF( TSTERR ) CALL ZERRLQT( PATH, NOUT ) + INFOT = 0 +* +* Do for each value of M in MVAL. +* + DO I = 1, NM + M = MVAL( I ) +* +* Do for each value of N in NVAL. +* + DO J = 1, NN + N = NVAL( J ) +* +* Do for each possible value of NB +* + MINMN = MIN( M, N ) + DO K = 1, NNB + NB = NBVAL( K ) +* +* Test ZGELQT and ZUNMLQT +* + IF( (NB.LE.MINMN).AND.(NB.GT.0) ) THEN + CALL ZLQT04( M, N, NB, RESULT ) +* +* Print information about the tests that did not +* pass the threshold. +* + DO T = 1, NTESTS + IF( RESULT( T ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 )M, N, NB, + $ T, RESULT( T ) + NFAIL = NFAIL + 1 + END IF + END DO + NRUN = NRUN + NTESTS + END IF + END DO + END DO + END DO +* +* Print a summary of the results. +* + CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) +* + 9999 FORMAT( ' M=', I5, ', N=', I5, ', NB=', I4, + $ ' test(', I2, ')=', G12.5 ) + RETURN +* +* End of ZCHKLQT +* + END diff --git a/TESTING/LIN/zchklqtp.f b/TESTING/LIN/zchklqtp.f new file mode 100644 index 00000000..10f7363a --- /dev/null +++ b/TESTING/LIN/zchklqtp.f @@ -0,0 +1,215 @@ +*> \brief \b ZCHKLQTP +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZCHKLQTP( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, +* NBVAL, NOUT ) +* +* .. Scalar Arguments .. +* LOGICAL TSTERR +* INTEGER NM, NN, NNB, NOUT +* DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. +* INTEGER MVAL( * ), NBVAL( * ), NVAL( * ) +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZCHKLQTP tests ZTPLQT and ZTPMLQT. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] THRESH +*> \verbatim +*> THRESH is DOUBLE PRECISION +*> The threshold value for the test ratios. A result is +*> included in the output file if RESULT >= THRESH. To have +*> every test ratio printed, use THRESH = 0. +*> \endverbatim +*> +*> \param[in] TSTERR +*> \verbatim +*> TSTERR is LOGICAL +*> Flag that indicates whether error exits are to be tested. +*> \endverbatim +*> +*> \param[in] NM +*> \verbatim +*> NM is INTEGER +*> The number of values of M contained in the vector MVAL. +*> \endverbatim +*> +*> \param[in] MVAL +*> \verbatim +*> MVAL is INTEGER array, dimension (NM) +*> The values of the matrix row dimension M. +*> \endverbatim +*> +*> \param[in] NN +*> \verbatim +*> NN is INTEGER +*> The number of values of N contained in the vector NVAL. +*> \endverbatim +*> +*> \param[in] NVAL +*> \verbatim +*> NVAL is INTEGER array, dimension (NN) +*> The values of the matrix column dimension N. +*> \endverbatim +*> +*> \param[in] NNB +*> \verbatim +*> NNB is INTEGER +*> The number of values of NB contained in the vector NBVAL. +*> \endverbatim +*> +*> \param[in] NBVAL +*> \verbatim +*> NBVAL is INTEGER array, dimension (NBVAL) +*> The values of the blocksize NB. +*> \endverbatim +*> +*> \param[in] NOUT +*> \verbatim +*> NOUT is INTEGER +*> The unit number for output. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2011 +* +*> \ingroup double_lin +* +* ===================================================================== + SUBROUTINE ZCHKLQTP( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, + $ NBVAL, NOUT ) + IMPLICIT NONE +* +* -- LAPACK test routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + LOGICAL TSTERR + INTEGER NM, NN, NNB, NOUT + DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. + INTEGER MVAL( * ), NBVAL( * ), NVAL( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER NTESTS + PARAMETER ( NTESTS = 6 ) +* .. +* .. Local Scalars .. + CHARACTER*3 PATH + INTEGER I, J, K, L, T, M, N, NB, NFAIL, NERRS, NRUN, + $ MINMN +* .. +* .. Local Arrays .. + DOUBLE PRECISION RESULT( NTESTS ) +* .. +* .. External Subroutines .. + EXTERNAL ALAERH, ALAHD, ALASUM, ZERRLQTP, ZLQT04 +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, NUNIT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NUNIT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Executable Statements .. +* +* Initialize constants +* + PATH( 1: 1 ) = 'Z' + PATH( 2: 3 ) = 'XQ' + NRUN = 0 + NFAIL = 0 + NERRS = 0 +* +* Test the error exits +* + IF( TSTERR ) CALL ZERRLQTP( PATH, NOUT ) + INFOT = 0 +* +* Do for each value of M +* + DO I = 1, NM + M = MVAL( I ) +* +* Do for each value of N +* + DO J = 1, NN + N = NVAL( J ) +* +* Do for each value of L +* + MINMN = MIN( M, N ) + DO L = 0, MINMN, MAX( MINMN, 1 ) +* +* Do for each possible value of NB +* + DO K = 1, NNB + NB = NBVAL( K ) +* +* Test DTPLQT and DTPMLQT +* + IF( (NB.LE.M).AND.(NB.GT.0) ) THEN + CALL ZLQT05( M, N, L, NB, RESULT ) +* +* Print information about the tests that did not +* pass the threshold. +* + DO T = 1, NTESTS + IF( RESULT( T ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 )M, N, NB, L, + $ T, RESULT( T ) + NFAIL = NFAIL + 1 + END IF + END DO + NRUN = NRUN + NTESTS + END IF + END DO + END DO + END DO + END DO +* +* Print a summary of the results. +* + CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) +* + 9999 FORMAT( ' M=', I5, ', N=', I5, ', NB=', I4,' L=', I4, + $ ' test(', I2, ')=', G12.5 ) + RETURN +* +* End of ZCHKLQTP +* + END
\ No newline at end of file diff --git a/TESTING/LIN/zchktsqr.f b/TESTING/LIN/zchktsqr.f new file mode 100644 index 00000000..c79a92b7 --- /dev/null +++ b/TESTING/LIN/zchktsqr.f @@ -0,0 +1,257 @@ +*> \brief \b DCHKQRT +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZCHKTSQR( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, +* NBVAL, NOUT ) +* +* .. Scalar Arguments .. +* LOGICAL TSTERR +* INTEGER NM, NN, NNB, NOUT +* DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. +* INTEGER MVAL( * ), NBVAL( * ), NVAL( * ) +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZCHKTSQR tests ZGEQR and ZGEMQR. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] THRESH +*> \verbatim +*> THRESH is DOUBLE PRECISION +*> The threshold value for the test ratios. A result is +*> included in the output file if RESULT >= THRESH. To have +*> every test ratio printed, use THRESH = 0. +*> \endverbatim +*> +*> \param[in] TSTERR +*> \verbatim +*> TSTERR is LOGICAL +*> Flag that indicates whether error exits are to be tested. +*> \endverbatim +*> +*> \param[in] NM +*> \verbatim +*> NM is INTEGER +*> The number of values of M contained in the vector MVAL. +*> \endverbatim +*> +*> \param[in] MVAL +*> \verbatim +*> MVAL is INTEGER array, dimension (NM) +*> The values of the matrix row dimension M. +*> \endverbatim +*> +*> \param[in] NN +*> \verbatim +*> NN is INTEGER +*> The number of values of N contained in the vector NVAL. +*> \endverbatim +*> +*> \param[in] NVAL +*> \verbatim +*> NVAL is INTEGER array, dimension (NN) +*> The values of the matrix column dimension N. +*> \endverbatim +*> +*> \param[in] NNB +*> \verbatim +*> NNB is INTEGER +*> The number of values of NB contained in the vector NBVAL. +*> \endverbatim +*> +*> \param[in] NBVAL +*> \verbatim +*> NBVAL is INTEGER array, dimension (NBVAL) +*> The values of the blocksize NB. +*> \endverbatim +*> +*> \param[in] NOUT +*> \verbatim +*> NOUT is INTEGER +*> The unit number for output. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2011 +* +*> \ingroup double_lin +* +* ===================================================================== + SUBROUTINE ZCHKTSQR( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, + $ NBVAL, NOUT ) + IMPLICIT NONE +* +* -- LAPACK test routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + LOGICAL TSTERR + INTEGER NM, NN, NNB, NOUT + DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. + INTEGER MVAL( * ), NBVAL( * ), NVAL( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER NTESTS + PARAMETER ( NTESTS = 6 ) +* .. +* .. Local Scalars .. + CHARACTER*3 PATH + INTEGER I, J, K, T, M, N, NB, NFAIL, NERRS, NRUN, INB, + $ MINMN, MB, IMB +* +* .. Local Arrays .. + DOUBLE PRECISION RESULT( NTESTS ) +* .. +* .. External Subroutines .. + EXTERNAL ALAERH, ALAHD, ALASUM, DERRTSQR, + $ DTSQR01, XLAENV +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, NUNIT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NUNIT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Executable Statements .. +* +* Initialize constants +* + PATH( 1: 1 ) = 'Z' + PATH( 2: 3 ) = 'TS' + NRUN = 0 + NFAIL = 0 + NERRS = 0 +* +* Test the error exits +* + IF( TSTERR ) CALL ZERRTSQR( PATH, NOUT ) + INFOT = 0 +* +* Do for each value of M in MVAL. +* + DO I = 1, NM + M = MVAL( I ) +* +* Do for each value of N in NVAL. +* + DO J = 1, NN + N = NVAL( J ) + IF (MIN(M,N).NE.0) THEN + DO INB = 1, NNB + MB = NBVAL( INB ) + CALL XLAENV( 1, MB ) + DO IMB = 1, NNB + NB = NBVAL( IMB ) + CALL XLAENV( 2, NB ) +* +* Test ZGEQR and ZGEMQR +* + CALL ZTSQR01( 'TS', M, N, MB, NB, RESULT ) +* +* Print information about the tests that did not +* pass the threshold. +* + DO T = 1, NTESTS + IF( RESULT( T ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 )M, N, MB, NB, + $ T, RESULT( T ) + NFAIL = NFAIL + 1 + END IF + END DO + NRUN = NRUN + NTESTS + END DO + END DO + END IF + END DO + END DO +* +* Do for each value of M in MVAL. +* + DO I = 1, NM + M = MVAL( I ) +* +* Do for each value of N in NVAL. +* + DO J = 1, NN + N = NVAL( J ) + IF (MIN(M,N).NE.0) THEN + DO INB = 1, NNB + MB = NBVAL( INB ) + CALL XLAENV( 1, MB ) + DO IMB = 1, NNB + NB = NBVAL( IMB ) + CALL XLAENV( 2, NB ) +* +* Test ZGELQ and ZGEMLQ +* + CALL ZTSQR01( 'SW', M, N, MB, NB, RESULT ) +* +* Print information about the tests that did not +* pass the threshold. +* + DO T = 1, NTESTS + IF( RESULT( T ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9998 )M, N, MB, NB, + $ T, RESULT( T ) + NFAIL = NFAIL + 1 + END IF + END DO + NRUN = NRUN + NTESTS + END DO + END DO + END IF + END DO + END DO +* +* Print a summary of the results. +* + CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) +* + 9999 FORMAT( 'TS: M=', I5, ', N=', I5, ', MB=', I5, + $ ', NB=', I5,' test(', I2, ')=', G12.5 ) + 9998 FORMAT( 'SW: M=', I5, ', N=', I5, ', MB=', I5, + $ ', NB=', I5,' test(', I2, ')=', G12.5 ) + RETURN +* +* End of ZCHKQRT +* + END diff --git a/TESTING/LIN/zdrvls.f b/TESTING/LIN/zdrvls.f index 95a7ff35..72cb48e3 100644 --- a/TESTING/LIN/zdrvls.f +++ b/TESTING/LIN/zdrvls.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE ZDRVLS( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, NNB, * NBVAL, NXVAL, THRESH, TSTERR, A, COPYA, B, * COPYB, C, S, COPYS, WORK, RWORK, IWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NM, NN, NNB, NNS, NOUT @@ -25,7 +25,7 @@ * COMPLEX*16 A( * ), B( * ), C( * ), COPYA( * ), COPYB( * ), * $ WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -195,10 +195,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date November 2015 * @@ -232,7 +232,7 @@ * * .. Parameters .. INTEGER NTESTS - PARAMETER ( NTESTS = 14 ) + PARAMETER ( NTESTS = 16 ) INTEGER SMLSIZ PARAMETER ( SMLSIZ = 25 ) DOUBLE PRECISION ONE, ZERO @@ -247,7 +247,7 @@ INTEGER CRANK, I, IM, IN, INB, INFO, INS, IRANK, $ ISCALE, ITRAN, ITYPE, J, K, LDA, LDB, LDWORK, $ LWLSY, LWORK, M, MNMIN, N, NB, NCOLS, NERRS, - $ NFAIL, NRHS, NROWS, NRUN, RANK + $ NFAIL, NRHS, NROWS, NRUN, RANK, MB, LWTS DOUBLE PRECISION EPS, NORMA, NORMB, RCOND * .. * .. Local Arrays .. @@ -262,7 +262,7 @@ EXTERNAL ALAERH, ALAHD, ALASVM, DAXPY, DLASRT, XLAENV, $ ZDSCAL, ZERRLS, ZGELS, ZGELSD, ZGELSS, $ ZGELSY, ZGEMM, ZLACPY, ZLARNV, ZQRT13, ZQRT15, - $ ZQRT16 + $ ZQRT16, ZGETSLS * .. * .. Intrinsic Functions .. INTRINSIC DBLE, MAX, MIN, SQRT @@ -315,13 +315,19 @@ * DO 130 IN = 1, NN N = NVAL( IN ) - MNMIN = MIN( M, N ) + MNMIN = MAX(MIN( M, N ),1) LDB = MAX( 1, M, N ) + MB = (MNMIN+1) + IF(MINMN.NE.MB) THEN + LWTS = (((LDB-MB)/(MB-MNMIN))*MNMIN+LDB*2)*MB+5 + ELSE + LWTS = 2*MINMN+5 + END IF * DO 120 INS = 1, NNS NRHS = NSVAL( INS ) LWORK = MAX( 1, ( M+NRHS )*( N+2 ), ( N+NRHS )*( M+2 ), - $ M*N+4*MNMIN+MAX( M, N ), 2*N+M ) + $ M*N+4*MNMIN+MAX( M, N ), 2*N+M, LWTS ) * DO 110 IRANK = 1, 2 DO 100 ISCALE = 1, 3 @@ -431,6 +437,110 @@ NRUN = NRUN + 2 30 CONTINUE 40 CONTINUE +* +* +* Test ZGETSLS +* +* Generate a matrix of scaling type ISCALE +* + CALL ZQRT13( ISCALE, M, N, COPYA, LDA, NORMA, + $ ISEED ) + DO 65 INB = 1, NNB + MB = NBVAL( INB ) + CALL XLAENV( 1, MB ) + DO 62 IMB = 1, NNB + NB = NBVAL( IMB ) + CALL XLAENV( 2, NB ) +* + DO 60 ITRAN = 1, 2 + IF( ITRAN.EQ.1 ) THEN + TRANS = 'N' + NROWS = M + NCOLS = N + ELSE + TRANS = 'C' + NROWS = N + NCOLS = M + END IF + LDWORK = MAX( 1, NCOLS ) +* +* Set up a consistent rhs +* + IF( NCOLS.GT.0 ) THEN + CALL ZLARNV( 2, ISEED, NCOLS*NRHS, + $ WORK ) + CALL ZSCAL( NCOLS*NRHS, + $ ONE / DBLE( NCOLS ), WORK, + $ 1 ) + END IF + CALL ZGEMM( TRANS, 'No transpose', NROWS, + $ NRHS, NCOLS, CONE, COPYA, LDA, + $ WORK, LDWORK, CZERO, B, LDB ) + CALL ZLACPY( 'Full', NROWS, NRHS, B, LDB, + $ COPYB, LDB ) +* +* Solve LS or overdetermined system +* + IF( M.GT.0 .AND. N.GT.0 ) THEN + CALL ZLACPY( 'Full', M, N, COPYA, LDA, + $ A, LDA ) + CALL ZLACPY( 'Full', NROWS, NRHS, + $ COPYB, LDB, B, LDB ) + END IF + SRNAMT = 'DGETSLS ' + CALL ZGETSLS( TRANS, M, N, NRHS, A, + $ LDA, B, LDB, WORK, LWORK, INFO ) + IF( INFO.NE.0 ) + $ CALL ALAERH( PATH, 'ZGETSLS ', INFO, 0, + $ TRANS, M, N, NRHS, -1, NB, + $ ITYPE, NFAIL, NERRS, + $ NOUT ) +* +* Check correctness of results +* + LDWORK = MAX( 1, NROWS ) + IF( NROWS.GT.0 .AND. NRHS.GT.0 ) + $ CALL ZLACPY( 'Full', NROWS, NRHS, + $ COPYB, LDB, C, LDB ) + CALL ZQRT16( TRANS, M, N, NRHS, COPYA, + $ LDA, B, LDB, C, LDB, WORK, + $ RESULT( 15 ) ) +* + IF( ( ITRAN.EQ.1 .AND. M.GE.N ) .OR. + $ ( ITRAN.EQ.2 .AND. M.LT.N ) ) THEN +* +* Solving LS system +* + RESULT( 16 ) = ZQRT17( TRANS, 1, M, N, + $ NRHS, COPYA, LDA, B, LDB, + $ COPYB, LDB, C, WORK, + $ LWORK ) + ELSE +* +* Solving overdetermined system +* + RESULT( 16 ) = ZQRT14( TRANS, M, N, + $ NRHS, COPYA, LDA, B, LDB, + $ WORK, LWORK ) + END IF +* +* Print information about the tests that +* did not pass the threshold. +* + DO 50 K = 15, 16 + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9997 )TRANS, M, + $ N, NRHS, MB, NB, ITYPE, K, + $ RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 50 CONTINUE + NRUN = NRUN + 2 + 60 CONTINUE + 62 CONTINUE + 65 CONTINUE END IF * * Generate a matrix of scaling type ISCALE and rank @@ -635,7 +745,7 @@ * Print information about the tests that did not * pass the threshold. * - DO 80 K = 3, NTESTS + DO 80 K = 3, 14 IF( RESULT( K ).GE.THRESH ) THEN IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) $ CALL ALAHD( NOUT, PATH ) @@ -661,6 +771,9 @@ $ ', NB=', I4, ', type', I2, ', test(', I2, ')=', G12.5 ) 9998 FORMAT( ' M=', I5, ', N=', I5, ', NRHS=', I4, ', NB=', I4, $ ', type', I2, ', test(', I2, ')=', G12.5 ) + 9997 FORMAT( ' TRANS=''', A1,' M=', I5, ', N=', I5, ', NRHS=', I4, + $ ', MB=', I4,', NB=', I4,', type', I2, + $ ', test(', I2, ')=', G12.5 ) RETURN * * End of ZDRVLS diff --git a/TESTING/LIN/zerrlqt.f b/TESTING/LIN/zerrlqt.f new file mode 100644 index 00000000..fd6b4527 --- /dev/null +++ b/TESTING/LIN/zerrlqt.f @@ -0,0 +1,197 @@ +*> \brief \b ZERLQT +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZERRLQT( PATH, NUNIT ) +* +* .. Scalar Arguments .. +* CHARACTER*3 PATH +* INTEGER NUNIT +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZERRLQT tests the error exits for the COMPLEX routines +*> that use the LQT decomposition of a general matrix. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] PATH +*> \verbatim +*> PATH is CHARACTER*3 +*> The LAPACK path name for the routines to be tested. +*> \endverbatim +*> +*> \param[in] NUNIT +*> \verbatim +*> NUNIT is INTEGER +*> The unit number for output. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2011 +* +*> \ingroup double_lin +* +* ===================================================================== + SUBROUTINE ZERRLQT( PATH, NUNIT ) + IMPLICIT NONE +* +* -- LAPACK test routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + CHARACTER*3 PATH + INTEGER NUNIT +* .. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER NMAX + PARAMETER ( NMAX = 2 ) +* .. +* .. Local Scalars .. + INTEGER I, INFO, J +* .. +* .. Local Arrays .. + COMPLEX*16 A( NMAX, NMAX ), T( NMAX, NMAX ), W( NMAX ), + $ C( NMAX, NMAX ) +* .. +* .. External Subroutines .. + EXTERNAL ALAESM, CHKXER, ZGELQT3, ZGELQT, + $ ZGEMLQT +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, NOUT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NOUT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE, DCMPLX +* .. +* .. Executable Statements .. +* + NOUT = NUNIT + WRITE( NOUT, FMT = * ) +* +* Set the variables to innocuous values. +* + DO J = 1, NMAX + DO I = 1, NMAX + A( I, J ) = 1.D0 / DCMPLX( DBLE( I+J ), 0.D0 ) + C( I, J ) = 1.D0 / DCMPLX( DBLE( I+J ), 0.D0 ) + T( I, J ) = 1.D0 / DCMPLX( DBLE( I+J ), 0.D0 ) + END DO + W( J ) = 0.D0 + END DO + OK = .TRUE. +* +* Error exits for LQT factorization +* +* ZGELQT +* + SRNAMT = 'ZGELQT' + INFOT = 1 + CALL ZGELQT( -1, 0, 1, A, 1, T, 1, W, INFO ) + CALL CHKXER( 'ZGELQT', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZGELQT( 0, -1, 1, A, 1, T, 1, W, INFO ) + CALL CHKXER( 'ZGELQT', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZGELQT( 0, 0, 0, A, 1, T, 1, W, INFO ) + CALL CHKXER( 'ZGELQT', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL ZGELQT( 2, 1, 1, A, 1, T, 1, W, INFO ) + CALL CHKXER( 'ZGELQT', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL ZGELQT( 2, 2, 2, A, 2, T, 1, W, INFO ) + CALL CHKXER( 'ZGELQT', INFOT, NOUT, LERR, OK ) +* +* ZGELQT3 +* + SRNAMT = 'ZGELQT3' + INFOT = 1 + CALL ZGELQT3( -1, 0, A, 1, T, 1, INFO ) + CALL CHKXER( 'ZGELQT3', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZGELQT3( 0, -1, A, 1, T, 1, INFO ) + CALL CHKXER( 'ZGELQT3', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZGELQT3( 2, 2, A, 1, T, 1, INFO ) + CALL CHKXER( 'ZGELQT3', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL ZGELQT3( 2, 2, A, 2, T, 1, INFO ) + CALL CHKXER( 'ZGELQT3', INFOT, NOUT, LERR, OK ) +* +* ZGEMLQT +* + SRNAMT = 'ZGEMLQT' + INFOT = 1 + CALL ZGEMLQT( '/', 'N', 0, 0, 0, 1, A, 1, T, 1, C, 1, W, INFO ) + CALL CHKXER( 'ZGEMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZGEMLQT( 'L', '/', 0, 0, 0, 1, A, 1, T, 1, C, 1, W, INFO ) + CALL CHKXER( 'ZGEMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZGEMLQT( 'L', 'N', -1, 0, 0, 1, A, 1, T, 1, C, 1, W, INFO ) + CALL CHKXER( 'ZGEMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZGEMLQT( 'L', 'N', 0, -1, 0, 1, A, 1, T, 1, C, 1, W, INFO ) + CALL CHKXER( 'ZGEMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL ZGEMLQT( 'L', 'N', 0, 0, -1, 1, A, 1, T, 1, C, 1, W, INFO ) + CALL CHKXER( 'ZGEMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL ZGEMLQT( 'R', 'N', 0, 0, -1, 1, A, 1, T, 1, C, 1, W, INFO ) + CALL CHKXER( 'ZGEMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL ZGEMLQT( 'L', 'N', 0, 0, 0, 0, A, 1, T, 1, C, 1, W, INFO ) + CALL CHKXER( 'ZGEMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL ZGEMLQT( 'R', 'N', 2, 2, 2, 1, A, 1, T, 1, C, 1, W, INFO ) + CALL CHKXER( 'ZGEMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL ZGEMLQT( 'L', 'N', 2, 2, 2, 1, A, 1, T, 1, C, 1, W, INFO ) + CALL CHKXER( 'ZGEMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL ZGEMLQT( 'R', 'N', 1, 1, 1, 1, A, 1, T, 0, C, 1, W, INFO ) + CALL CHKXER( 'ZGEMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 12 + CALL ZGEMLQT( 'L', 'N', 1, 1, 1, 1, A, 1, T, 1, C, 0, W, INFO ) + CALL CHKXER( 'ZGEMLQT', INFOT, NOUT, LERR, OK ) +* +* Print a summary line. +* + CALL ALAESM( PATH, OK, NOUT ) +* + RETURN +* +* End of ZERRLQT +* + END diff --git a/TESTING/LIN/zerrlqtp.f b/TESTING/LIN/zerrlqtp.f new file mode 100644 index 00000000..25a079ec --- /dev/null +++ b/TESTING/LIN/zerrlqtp.f @@ -0,0 +1,225 @@ +*> \brief \b ZERRLQTP +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZERRLQTP( PATH, NUNIT ) +* +* .. Scalar Arguments .. +* CHARACTER*3 PATH +* INTEGER NUNIT +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZERRLQTP tests the error exits for the complex routines +*> that use the LQT decomposition of a triangular-pentagonal matrix. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] PATH +*> \verbatim +*> PATH is CHARACTER*3 +*> The LAPACK path name for the routines to be tested. +*> \endverbatim +*> +*> \param[in] NUNIT +*> \verbatim +*> NUNIT is INTEGER +*> The unit number for output. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2011 +* +*> \ingroup double_lin +* +* ===================================================================== + SUBROUTINE ZERRLQTP( PATH, NUNIT ) + IMPLICIT NONE +* +* -- LAPACK test routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + CHARACTER*3 PATH + INTEGER NUNIT +* .. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER NMAX + PARAMETER ( NMAX = 2 ) +* .. +* .. Local Scalars .. + INTEGER I, INFO, J +* .. +* .. Local Arrays .. + COMPLEX*16 A( NMAX, NMAX ), T( NMAX, NMAX ), W( NMAX ), + $ B( NMAX, NMAX ), C( NMAX, NMAX ) +* .. +* .. External Subroutines .. + EXTERNAL ALAESM, CHKXER, ZTPLQT2, ZTPLQT, + $ ZTPMLQT +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, NOUT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NOUT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE, DCMPLX +* .. +* .. Executable Statements .. +* + NOUT = NUNIT + WRITE( NOUT, FMT = * ) +* +* Set the variables to innocuous values. +* + DO J = 1, NMAX + DO I = 1, NMAX + A( I, J ) = 1.D0 / DCMPLX( DBLE( I+J ), 0.D0 ) + C( I, J ) = 1.D0 / DCMPLX( DBLE( I+J ), 0.D0 ) + T( I, J ) = 1.D0 / DCMPLX( DBLE( I+J ), 0.D0 ) + END DO + W( J ) = 0.0 + END DO + OK = .TRUE. +* +* Error exits for TPLQT factorization +* +* ZTPLQT +* + SRNAMT = 'ZTPLQT' + INFOT = 1 + CALL ZTPLQT( -1, 1, 0, 1, A, 1, B, 1, T, 1, W, INFO ) + CALL CHKXER( 'ZTPLQT', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZTPLQT( 1, -1, 0, 1, A, 1, B, 1, T, 1, W, INFO ) + CALL CHKXER( 'ZTPLQT', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZTPLQT( 0, 1, -1, 1, A, 1, B, 1, T, 1, W, INFO ) + CALL CHKXER( 'ZTPLQT', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZTPLQT( 0, 1, 1, 1, A, 1, B, 1, T, 1, W, INFO ) + CALL CHKXER( 'ZTPLQT', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZTPLQT( 0, 1, 0, 0, A, 1, B, 1, T, 1, W, INFO ) + CALL CHKXER( 'ZTPLQT', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZTPLQT( 1, 1, 0, 2, A, 1, B, 1, T, 1, W, INFO ) + CALL CHKXER( 'ZTPLQT', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL ZTPLQT( 2, 1, 0, 2, A, 1, B, 1, T, 1, W, INFO ) + CALL CHKXER( 'ZTPLQT', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL ZTPLQT( 2, 1, 0, 1, A, 2, B, 1, T, 1, W, INFO ) + CALL CHKXER( 'ZTPLQT', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL ZTPLQT( 2, 2, 1, 2, A, 2, B, 2, T, 1, W, INFO ) + CALL CHKXER( 'ZTPLQT', INFOT, NOUT, LERR, OK ) +* +* ZTPLQT2 +* + SRNAMT = 'ZTPLQT2' + INFOT = 1 + CALL ZTPLQT2( -1, 0, 0, A, 1, B, 1, T, 1, INFO ) + CALL CHKXER( 'ZTPLQT2', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZTPLQT2( 0, -1, 0, A, 1, B, 1, T, 1, INFO ) + CALL CHKXER( 'ZTPLQT2', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZTPLQT2( 0, 0, -1, A, 1, B, 1, T, 1, INFO ) + CALL CHKXER( 'ZTPLQT2', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL ZTPLQT2( 2, 2, 0, A, 1, B, 2, T, 2, INFO ) + CALL CHKXER( 'ZTPLQT2', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL ZTPLQT2( 2, 2, 0, A, 2, B, 1, T, 2, INFO ) + CALL CHKXER( 'ZTPLQT2', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL ZTPLQT2( 2, 2, 0, A, 2, B, 2, T, 1, INFO ) + CALL CHKXER( 'ZTPLQT2', INFOT, NOUT, LERR, OK ) +* +* ZTPMLQT +* + SRNAMT = 'ZTPMLQT' + INFOT = 1 + CALL ZTPMLQT( '/', 'N', 0, 0, 0, 0, 1, A, 1, T, 1, B, 1, C, 1, + $ W, INFO ) + CALL CHKXER( 'ZTPMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZTPMLQT( 'L', '/', 0, 0, 0, 0, 1, A, 1, T, 1, B, 1, C, 1, + $ W, INFO ) + CALL CHKXER( 'ZTPMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZTPMLQT( 'L', 'N', -1, 0, 0, 0, 1, A, 1, T, 1, B, 1, C, 1, + $ W, INFO ) + CALL CHKXER( 'ZTPMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZTPMLQT( 'L', 'N', 0, -1, 0, 0, 1, A, 1, T, 1, B, 1, C, 1, + $ W, INFO ) + CALL CHKXER( 'ZTPMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL ZTPMLQT( 'L', 'N', 0, 0, -1, 0, 1, A, 1, T, 1, B, 1, C, 1, + $ W, INFO ) + INFOT = 6 + CALL ZTPMLQT( 'L', 'N', 0, 0, 0, -1, 1, A, 1, T, 1, B, 1, C, 1, + $ W, INFO ) + CALL CHKXER( 'ZTPMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL ZTPMLQT( 'L', 'N', 0, 0, 0, 0, 0, A, 1, T, 1, B, 1, C, 1, + $ W, INFO ) + CALL CHKXER( 'ZTPMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL ZTPMLQT( 'R', 'N', 2, 2, 2, 1, 1, A, 1, T, 1, B, 1, C, 1, + $ W, INFO ) + CALL CHKXER( 'ZTPMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL ZTPMLQT( 'R', 'N', 1, 1, 1, 1, 1, A, 1, T, 0, B, 1, C, 1, + $ W, INFO ) + CALL CHKXER( 'ZTPMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 13 + CALL ZTPMLQT( 'L', 'N', 1, 1, 1, 1, 1, A, 1, T, 1, B, 0, C, 1, + $ W, INFO ) + CALL CHKXER( 'ZTPMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 15 + CALL ZTPMLQT( 'L', 'N', 1, 1, 1, 1, 1, A, 1, T, 1, B, 1, C, 0, + $ W, INFO ) + CALL CHKXER( 'ZTPMLQT', INFOT, NOUT, LERR, OK ) +* +* Print a summary line. +* + CALL ALAESM( PATH, OK, NOUT ) +* + RETURN +* +* End of ZERRLQT +* + END diff --git a/TESTING/LIN/zerrtsqr.f b/TESTING/LIN/zerrtsqr.f new file mode 100644 index 00000000..19c99805 --- /dev/null +++ b/TESTING/LIN/zerrtsqr.f @@ -0,0 +1,243 @@ +*> \brief \b ZERRTSQR +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZERRTSQR( PATH, NUNIT ) +* +* .. Scalar Arguments .. +* CHARACTER*3 PATH +* INTEGER NUNIT +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZERRTSQR tests the error exits for the ZOUBLE PRECISION routines +*> that use the TSQR decomposition of a general matrix. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] PATH +*> \verbatim +*> PATH is CHARACTER*3 +*> The LAPACK path name for the routines to be tested. +*> \endverbatim +*> +*> \param[in] NUNIT +*> \verbatim +*> NUNIT is INTEGER +*> The unit number for output. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Zenver +*> \author NAG Ltd. +* +*> \date November 2011 +* +*> \ingroup double_lin +* +* ===================================================================== + SUBROUTINE ZERRTSQR( PATH, NUNIT ) + IMPLICIT NONE +* +* -- LAPACK test routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + CHARACTER*3 PATH + INTEGER NUNIT +* .. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER NMAX + PARAMETER ( NMAX = 2 ) +* .. +* .. Local Scalars .. + INTEGER I, INFO, J, NB +* .. +* .. Local Arrays .. + COMPLEX*16 A( NMAX, NMAX ), T( NMAX, NMAX ), W( NMAX ), + $ C( NMAX, NMAX ), TAU(NMAX) +* .. +* .. External Subroutines .. + EXTERNAL ALAESM, CHKXER, ZGEQR, + $ ZGEMQR, ZGELQ, ZGEMLQ +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, NOUT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NOUT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE +* .. +* .. Executable Statements .. +* + NOUT = NUNIT + WRITE( NOUT, FMT = * ) +* +* Set the variables to innocuous values. +* + DO J = 1, NMAX + DO I = 1, NMAX + A( I, J ) = 1.D0 / DBLE( I+J ) + C( I, J ) = 1.D0 / DBLE( I+J ) + T( I, J ) = 1.D0 / DBLE( I+J ) + END DO + W( J ) = 0.D0 + END DO + OK = .TRUE. +* +* Error exits for TS factorization +* +* ZGEQR +* + SRNAMT = 'ZGEQR' + INFOT = 1 + CALL ZGEQR( -1, 0, A, 1, TAU, 1, W, 1, INFO ) + CALL CHKXER( 'ZGEQR', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZGEQR( 0, -1, A, 1, TAU, 1, W, 1, INFO ) + CALL CHKXER( 'ZGEQR', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZGEQR( 1, 1, A, 0, TAU, 1, W, 1, INFO ) + CALL CHKXER( 'ZGEQR', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL ZGEQR( 3, 2, A, 3, TAU, 1, W, 1, INFO ) + CALL CHKXER( 'ZGEQR', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL ZGEQR( 3, 2, A, 3, TAU, 8, W, 0, INFO ) + CALL CHKXER( 'ZGEQR', INFOT, NOUT, LERR, OK ) +* +* ZGEMQR +* + TAU(1)=1 + TAU(2)=1 + SRNAMT = 'ZGEMQR' + NB=1 + INFOT = 1 + CALL ZGEMQR( '/', 'N', 0, 0, 0, A, 1, TAU, 1, C, 1, W, 1,INFO) + CALL CHKXER( 'ZGEMQR', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZGEMQR( 'L', '/', 0, 0, 0, A, 1, TAU, 1, C, 1, W, 1,INFO) + CALL CHKXER( 'ZGEMQR', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZGEMQR( 'L', 'N', -1, 0, 0, A, 1, TAU, 1, C, 1, W,1,INFO) + CALL CHKXER( 'ZGEMQR', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZGEMQR( 'L', 'N', 0, -1, 0, A, 1, TAU, 1, C, 1, W,1,INFO) + CALL CHKXER( 'ZGEMQR', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL ZGEMQR( 'L', 'N', 0, 0, -1, A, 1, TAU, 1, C, 1, W,1,INFO) + CALL CHKXER( 'ZGEMQR', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL ZGEMQR( 'R', 'N', 0, 0, -1, A, 1, TAU, 1, C, 1, W,1,INFO) + CALL CHKXER( 'ZGEMQR', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL ZGEMQR( 'L', 'N', 2, 1, 0, A, 0, TAU, 1, C, 1, W, 1,INFO) + CALL CHKXER( 'ZGEMQR', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL ZGEMQR( 'R', 'N', 2, 2, 1, A, 1, TAU, 0, C, 1, W, 1,INFO) + CALL CHKXER( 'ZGEMQR', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL ZGEMQR( 'L', 'N', 2, 2, 1, A, 1, TAU, 0, C, 1, W, 1,INFO) + CALL CHKXER( 'ZGEMQR', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL ZGEMQR( 'L', 'N', 2, 1, 1, A, 1, TAU, 6, C, 0, W, 1,INFO) + CALL CHKXER( 'ZGEMQR', INFOT, NOUT, LERR, OK ) + INFOT = 13 + CALL ZGEMQR( 'L', 'N', 2, 2, 1, A, 2, TAU, 6, C, 2, W, 0,INFO) + CALL CHKXER( 'ZGEMQR', INFOT, NOUT, LERR, OK ) +* +* ZGELQ +* + SRNAMT = 'ZGELQ' + INFOT = 1 + CALL ZGELQ( -1, 0, A, 1, TAU, 1, W, 1, INFO ) + CALL CHKXER( 'ZGELQ', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZGELQ( 0, -1, A, 1, TAU, 1, W, 1, INFO ) + CALL CHKXER( 'ZGELQ', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZGELQ( 1, 1, A, 0, TAU, 1, W, 1, INFO ) + CALL CHKXER( 'ZGELQ', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL ZGELQ( 2, 3, A, 3, TAU, 1, W, 1, INFO ) + CALL CHKXER( 'ZGELQ', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL ZGELQ( 2, 3, A, 3, TAU, 8, W, 0, INFO ) + CALL CHKXER( 'ZGELQ', INFOT, NOUT, LERR, OK ) +* +* ZGEMLQ +* + TAU(1)=1 + TAU(2)=1 + SRNAMT = 'ZGEMLQ' + NB=1 + INFOT = 1 + CALL ZGEMLQ( '/', 'N', 0, 0, 0, A, 1, TAU, 1, C, 1, W, 1,INFO) + CALL CHKXER( 'ZGEMLQ', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZGEMLQ( 'L', '/', 0, 0, 0, A, 1, TAU, 1, C, 1, W, 1,INFO) + CALL CHKXER( 'ZGEMLQ', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZGEMLQ( 'L', 'N', -1, 0, 0, A, 1, TAU, 1, C, 1, W,1,INFO) + CALL CHKXER( 'ZGEMLQ', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZGEMLQ( 'L', 'N', 0, -1, 0, A, 1, TAU, 1, C, 1, W,1,INFO) + CALL CHKXER( 'ZGEMLQ', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL ZGEMLQ( 'L', 'N', 0, 0, -1, A, 1, TAU, 1, C, 1, W,1,INFO) + CALL CHKXER( 'ZGEMLQ', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL ZGEMLQ( 'R', 'N', 0, 0, -1, A, 1, TAU, 1, C, 1, W,1,INFO) + CALL CHKXER( 'ZGEMLQ', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL ZGEMLQ( 'L', 'N', 1, 2, 0, A, 0, TAU, 1, C, 1, W, 1,INFO) + CALL CHKXER( 'ZGEMLQ', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL ZGEMLQ( 'R', 'N', 2, 2, 1, A, 1, TAU, 0, C, 1, W, 1,INFO) + CALL CHKXER( 'ZGEMLQ', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL ZGEMLQ( 'L', 'N', 2, 2, 1, A, 1, TAU, 0, C, 1, W, 1,INFO) + CALL CHKXER( 'ZGEMLQ', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL ZGEMLQ( 'L', 'N', 1, 2, 1, A, 1, TAU, 6, C, 0, W, 1,INFO) + CALL CHKXER( 'ZGEMLQ', INFOT, NOUT, LERR, OK ) + INFOT = 13 + CALL ZGEMLQ( 'L', 'N', 2, 2, 1, A, 2, TAU, 6, C, 2, W, 0,INFO) + CALL CHKXER( 'ZGEMLQ', INFOT, NOUT, LERR, OK ) +* +* Print a summary line. +* + CALL ALAESM( PATH, OK, NOUT ) +* + RETURN +* +* End of DERRTSQR +* + END diff --git a/TESTING/LIN/zlqt04.f b/TESTING/LIN/zlqt04.f new file mode 100644 index 00000000..a1aff90e --- /dev/null +++ b/TESTING/LIN/zlqt04.f @@ -0,0 +1,262 @@ +*> \brief \b DLQT04 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZLQT04(M,N,NB,RESULT) +* +* .. Scalar Arguments .. +* INTEGER M, N, NB +* .. Return values .. +* DOUBLE PRECISION RESULT(6) +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZLQT04 tests ZGELQT and ZUNMLQT. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> Number of rows in test matrix. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> Number of columns in test matrix. +*> \endverbatim +*> +*> \param[in] NB +*> \verbatim +*> NB is INTEGER +*> Block size of test matrix. NB <= Min(M,N). +*> \endverbatim +*> +*> \param[out] RESULT +*> \verbatim +*> RESULT is DOUBLE PRECISION array, dimension (6) +*> Results of each of the six tests below. +*> +*> RESULT(1) = | A - L Q | +*> RESULT(2) = | I - Q Q^H | +*> RESULT(3) = | Q C - Q C | +*> RESULT(4) = | Q^H C - Q^H C | +*> RESULT(5) = | C Q - C Q | +*> RESULT(6) = | C Q^H - C Q^H | +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date April 2012 +* +*> \ingroup double_lin +* +* ===================================================================== + SUBROUTINE ZLQT04(M,N,NB,RESULT) + IMPLICIT NONE +* +* -- LAPACK test routine (version 3.4.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* April 2012 +* +* .. Scalar Arguments .. + INTEGER M, N, NB +* .. Return values .. + DOUBLE PRECISION RESULT(6) +* +* ===================================================================== +* +* .. +* .. Local allocatable arrays + COMPLEX*16, ALLOCATABLE :: AF(:,:), Q(:,:), + $ L(:,:), RWORK(:), WORK( : ), T(:,:), + $ CF(:,:), DF(:,:), A(:,:), C(:,:), D(:,:) +* +* .. Parameters .. + DOUBLE PRECISION ZERO + COMPLEX*16 ONE, CZERO + PARAMETER( ZERO = 0.0) + PARAMETER( ONE = (1.0,0.0), CZERO=(0.0,0.0) ) +* .. +* .. Local Scalars .. + INTEGER INFO, J, K, LL, LWORK, LDT + DOUBLE PRECISION ANORM, EPS, RESID, CNORM, DNORM +* .. +* .. Local Arrays .. + INTEGER ISEED( 4 ) +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + DOUBLE PRECISION ZLANGE, ZLANSY + LOGICAL LSAME + EXTERNAL DLAMCH, ZLANGE, ZLANSY, LSAME +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Data statements .. + DATA ISEED / 1988, 1989, 1990, 1991 / +* + EPS = DLAMCH( 'Epsilon' ) + K = MIN(M,N) + LL = MAX(M,N) + LWORK = MAX(2,LL)*MAX(2,LL)*NB +* +* Dynamically allocate local arrays +* + ALLOCATE ( A(M,N), AF(M,N), Q(N,N), L(LL,N), RWORK(LL), + $ WORK(LWORK), T(NB,N), C(M,N), CF(M,N), + $ D(N,M), DF(N,M) ) +* +* Put random numbers into A and copy to AF +* + LDT=NB + DO J=1,N + CALL ZLARNV( 2, ISEED, M, A( 1, J ) ) + END DO + CALL ZLACPY( 'Full', M, N, A, M, AF, M ) +* +* Factor the matrix A in the array AF. +* + CALL ZGELQT( M, N, NB, AF, M, T, LDT, WORK, INFO ) +* +* Generate the n-by-n matrix Q +* + CALL ZLASET( 'Full', N, N, CZERO, ONE, Q, N ) + CALL ZGEMLQT( 'R', 'N', N, N, K, NB, AF, M, T, LDT, Q, N, + $ WORK, INFO ) +* +* Copy L +* + CALL ZLASET( 'Full', LL, N, CZERO, CZERO, L, LL ) + CALL ZLACPY( 'Lower', M, N, AF, M, L, LL ) +* +* Compute |L - A*Q'| / |A| and store in RESULT(1) +* + CALL ZGEMM( 'N', 'C', M, N, N, -ONE, A, M, Q, N, ONE, L, LL ) + ANORM = ZLANGE( '1', M, N, A, M, RWORK ) + RESID = ZLANGE( '1', M, N, L, LL, RWORK ) + IF( ANORM.GT.ZERO ) THEN + RESULT( 1 ) = RESID / (EPS*MAX(1,M)*ANORM) + ELSE + RESULT( 1 ) = ZERO + END IF +* +* Compute |I - Q'*Q| and store in RESULT(2) +* + CALL ZLASET( 'Full', N, N, CZERO, ONE, L, LL ) + CALL ZHERK( 'U', 'C', N, N, DREAL(-ONE), Q, N, DREAL(ONE), L, LL) + RESID = ZLANSY( '1', 'Upper', N, L, LL, RWORK ) + RESULT( 2 ) = RESID / (EPS*MAX(1,N)) +* +* Generate random m-by-n matrix C and a copy CF +* + DO J=1,M + CALL ZLARNV( 2, ISEED, N, D( 1, J ) ) + END DO + DNORM = ZLANGE( '1', N, M, D, N, RWORK) + CALL ZLACPY( 'Full', N, M, D, N, DF, N ) +* +* Apply Q to C as Q*C +* + CALL ZGEMLQT( 'L', 'N', N, M, K, NB, AF, M, T, NB, DF, N, + $ WORK, INFO) +* +* Compute |Q*D - Q*D| / |D| +* + CALL ZGEMM( 'N', 'N', N, M, N, -ONE, Q, N, D, N, ONE, DF, N ) + RESID = ZLANGE( '1', N, M, DF, N, RWORK ) + IF( DNORM.GT.ZERO ) THEN + RESULT( 3 ) = RESID / (EPS*MAX(1,M)*DNORM) + ELSE + RESULT( 3 ) = ZERO + END IF +* +* Copy D into DF again +* + CALL ZLACPY( 'Full', N, M, D, N, DF, N ) +* +* Apply Q to D as QT*D +* + CALL ZGEMLQT( 'L', 'C', N, M, K, NB, AF, M, T, NB, DF, N, + $ WORK, INFO) +* +* Compute |QT*D - QT*D| / |D| +* + CALL ZGEMM( 'C', 'N', N, M, N, -ONE, Q, N, D, N, ONE, DF, N ) + RESID = ZLANGE( '1', N, M, DF, N, RWORK ) + IF( DNORM.GT.ZERO ) THEN + RESULT( 4 ) = RESID / (EPS*MAX(1,M)*DNORM) + ELSE + RESULT( 4 ) = ZERO + END IF +* +* Generate random n-by-m matrix D and a copy DF +* + DO J=1,N + CALL ZLARNV( 2, ISEED, M, C( 1, J ) ) + END DO + CNORM = ZLANGE( '1', M, N, C, M, RWORK) + CALL ZLACPY( 'Full', M, N, C, M, CF, M ) +* +* Apply Q to C as C*Q +* + CALL ZGEMLQT( 'R', 'N', M, N, K, NB, AF, M, T, NB, CF, M, + $ WORK, INFO) +* +* Compute |C*Q - C*Q| / |C| +* + CALL ZGEMM( 'N', 'N', M, N, N, -ONE, C, M, Q, N, ONE, CF, M ) + RESID = ZLANGE( '1', N, M, DF, N, RWORK ) + IF( CNORM.GT.ZERO ) THEN + RESULT( 5 ) = RESID / (EPS*MAX(1,M)*DNORM) + ELSE + RESULT( 5 ) = ZERO + END IF +* +* Copy C into CF again +* + CALL ZLACPY( 'Full', M, N, C, M, CF, M ) +* +* Apply Q to D as D*QT +* + CALL ZGEMLQT( 'R', 'C', M, N, K, NB, AF, M, T, NB, CF, M, + $ WORK, INFO) +* +* Compute |C*QT - C*QT| / |C| +* + CALL ZGEMM( 'N', 'C', M, N, N, -ONE, C, M, Q, N, ONE, CF, M ) + RESID = ZLANGE( '1', M, N, CF, M, RWORK ) + IF( CNORM.GT.ZERO ) THEN + RESULT( 6 ) = RESID / (EPS*MAX(1,M)*DNORM) + ELSE + RESULT( 6 ) = ZERO + END IF +* +* Deallocate all arrays +* + DEALLOCATE ( A, AF, Q, L, RWORK, WORK, T, C, D, CF, DF) +* + RETURN + END + diff --git a/TESTING/LIN/zlqt05.f b/TESTING/LIN/zlqt05.f new file mode 100644 index 00000000..676c95b8 --- /dev/null +++ b/TESTING/LIN/zlqt05.f @@ -0,0 +1,289 @@ +*> \brief \b ZLQT05 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZLQT05(M,N,L,NB,RESULT) +* +* .. Scalar Arguments .. +* INTEGER LWORK, M, N, L, NB, LDT +* .. Return values .. +* DOUBLE PRECISION RESULT(6) +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZQRT05 tests ZTPLQT and ZTPMLQT. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> Number of rows in lower part of the test matrix. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> Number of columns in test matrix. +*> \endverbatim +*> +*> \param[in] L +*> \verbatim +*> L is INTEGER +*> The number of rows of the upper trapezoidal part the +*> lower test matrix. 0 <= L <= M. +*> \endverbatim +*> +*> \param[in] NB +*> \verbatim +*> NB is INTEGER +*> Block size of test matrix. NB <= N. +*> \endverbatim +*> +*> \param[out] RESULT +*> \verbatim +*> RESULT is DOUBLE PRECISION array, dimension (6) +*> Results of each of the six tests below. +*> +*> RESULT(1) = | A - Q R | +*> RESULT(2) = | I - Q^H Q | +*> RESULT(3) = | Q C - Q C | +*> RESULT(4) = | Q^H C - Q^H C | +*> RESULT(5) = | C Q - C Q | +*> RESULT(6) = | C Q^H - C Q^H | +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date April 2012 +* +*> \ingroup double_lin +* +* ===================================================================== + SUBROUTINE ZLQT05(M,N,L,NB,RESULT) + IMPLICIT NONE +* +* -- LAPACK test routine (version 3.4.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* April 2012 +* +* .. Scalar Arguments .. + INTEGER LWORK, M, N, L, NB, LDT +* .. Return values .. + DOUBLE PRECISION RESULT(6) +* +* ===================================================================== +* +* .. +* .. Local allocatable arrays + COMPLEX*16, ALLOCATABLE :: AF(:,:), Q(:,:), + $ R(:,:), RWORK(:), WORK( : ), T(:,:), + $ CF(:,:), DF(:,:), A(:,:), C(:,:), D(:,:) +* +* .. Parameters .. + DOUBLE PRECISION ZERO + COMPLEX*16 ONE, CZERO + PARAMETER( ZERO = 0.0, ONE = (1.0,0.0), CZERO=(0.0,0.0) ) +* .. +* .. Local Scalars .. + INTEGER INFO, J, K, N2, NP1,i + DOUBLE PRECISION ANORM, EPS, RESID, CNORM, DNORM +* .. +* .. Local Arrays .. + INTEGER ISEED( 4 ) +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + DOUBLE PRECISION ZLANGE, ZLANSY + LOGICAL LSAME + EXTERNAL DLAMCH, ZLANGE, ZLANSY, LSAME +* .. +* .. Data statements .. + DATA ISEED / 1988, 1989, 1990, 1991 / +* + EPS = DLAMCH( 'Epsilon' ) + K = M + N2 = M+N + IF( N.GT.0 ) THEN + NP1 = M+1 + ELSE + NP1 = 1 + END IF + LWORK = N2*N2*NB +* +* Dynamically allocate all arrays +* + ALLOCATE(A(M,N2),AF(M,N2),Q(N2,N2),R(N2,N2),RWORK(N2), + $ WORK(LWORK),T(NB,M),C(N2,M),CF(N2,M), + $ D(M,N2),DF(M,N2) ) +* +* Put random stuff into A +* + LDT=NB + CALL ZLASET( 'Full', M, N2, CZERO, CZERO, A, M ) + CALL ZLASET( 'Full', NB, M, CZERO, CZERO, T, NB ) + DO J=1,M + CALL ZLARNV( 2, ISEED, M-J+1, A( J, J ) ) + END DO + IF( N.GT.0 ) THEN + DO J=1,N-L + CALL ZLARNV( 2, ISEED, M, A( 1, MIN(N+M,M+1) + J - 1 ) ) + END DO + END IF + IF( L.GT.0 ) THEN + DO J=1,L + CALL ZLARNV( 2, ISEED, M-J+1, A( J, MIN(N+M,N+M-L+1) + $ + J - 1 ) ) + END DO + END IF +* +* Copy the matrix A to the array AF. +* + CALL ZLACPY( 'Full', M, N2, A, M, AF, M ) +* +* Factor the matrix A in the array AF. +* + CALL ZTPLQT( M,N,L,NB,AF,M,AF(1,NP1),M,T,LDT,WORK,INFO) +* +* Generate the (M+N)-by-(M+N) matrix Q by applying H to I +* + CALL ZLASET( 'Full', N2, N2, CZERO, ONE, Q, N2 ) + CALL ZGEMLQT( 'L', 'N', N2, N2, K, NB, AF, M, T, LDT, Q, N2, + $ WORK, INFO ) +* +* Copy L +* + CALL ZLASET( 'Full', N2, N2, CZERO, CZERO, R, N2 ) + CALL ZLACPY( 'Lower', M, N2, AF, M, R, N2 ) +* +* Compute |L - A*Q*C| / |A| and store in RESULT(1) +* + CALL ZGEMM( 'N', 'C', M, N2, N2, -ONE, A, M, Q, N2, ONE, R, N2) + ANORM = ZLANGE( '1', M, N2, A, M, RWORK ) + RESID = ZLANGE( '1', M, N2, R, N2, RWORK ) + IF( ANORM.GT.ZERO ) THEN + RESULT( 1 ) = RESID / (EPS*ANORM*MAX(1,N2)) + ELSE + RESULT( 1 ) = ZERO + END IF +* +* Compute |I - Q*Q'| and store in RESULT(2) +* + CALL ZLASET( 'Full', N2, N2, CZERO, ONE, R, N2 ) + CALL ZHERK( 'U', 'N', N2, N2, DREAL(-ONE), Q, N2, DREAL(ONE), + $ R, N2 ) + RESID = ZLANSY( '1', 'Upper', N2, R, N2, RWORK ) + RESULT( 2 ) = RESID / (EPS*MAX(1,N2)) +* +* Generate random m-by-n matrix C and a copy CF +* + CALL ZLASET( 'Full', N2, M, CZERO, ONE, C, N2 ) + DO J=1,M + CALL ZLARNV( 2, ISEED, N2, C( 1, J ) ) + END DO + CNORM = ZLANGE( '1', N2, M, C, N2, RWORK) + CALL ZLACPY( 'Full', N2, M, C, N2, CF, N2 ) +* +* Apply Q to C as Q*C +* + CALL ZTPMLQT( 'L','N', N,M,K,L,NB,AF(1, NP1),M,T,LDT,CF,N2, + $ CF(NP1,1),N2,WORK,INFO) +* +* Compute |Q*C - Q*C| / |C| +* + CALL ZGEMM( 'N', 'N', N2, M, N2, -ONE, Q, N2, C, N2, ONE, CF, N2 ) + RESID = ZLANGE( '1', N2, M, CF, N2, RWORK ) + IF( CNORM.GT.ZERO ) THEN + RESULT( 3 ) = RESID / (EPS*MAX(1,N2)*CNORM) + ELSE + RESULT( 3 ) = ZERO + END IF + +* +* Copy C into CF again +* + CALL ZLACPY( 'Full', N2, M, C, N2, CF, N2 ) +* +* Apply Q to C as QT*C +* + CALL ZTPMLQT( 'L','C',N,M,K,L,NB,AF(1,NP1),M,T,LDT,CF,N2, + $ CF(NP1,1),N2,WORK,INFO) +* +* Compute |QT*C - QT*C| / |C| +* + CALL ZGEMM('C','N',N2,M,N2,-ONE,Q,N2,C,N2,ONE,CF,N2) + RESID = ZLANGE( '1', N2, M, CF, N2, RWORK ) + + IF( CNORM.GT.ZERO ) THEN + RESULT( 4 ) = RESID / (EPS*MAX(1,N2)*CNORM) + ELSE + RESULT( 4 ) = ZERO + END IF +* +* Generate random m-by-n matrix D and a copy DF +* + DO J=1,N2 + CALL ZLARNV( 2, ISEED, M, D( 1, J ) ) + END DO + DNORM = ZLANGE( '1', M, N2, D, M, RWORK) + CALL ZLACPY( 'Full', M, N2, D, M, DF, M ) +* +* Apply Q to D as D*Q +* + CALL ZTPMLQT('R','N',M,N,K,L,NB,AF(1,NP1),M,T,LDT,DF,M, + $ DF(1,NP1),M,WORK,INFO) +* +* Compute |D*Q - D*Q| / |D| +* + CALL ZGEMM('N','N',M,N2,N2,-ONE,D,M,Q,N2,ONE,DF,M) + RESID = ZLANGE('1',M, N2,DF,M,RWORK ) + IF( CNORM.GT.ZERO ) THEN + RESULT( 5 ) = RESID / (EPS*MAX(1,N2)*DNORM) + ELSE + RESULT( 5 ) = ZERO + END IF +* +* Copy D into DF again +* + CALL ZLACPY('Full',M,N2,D,M,DF,M ) +* +* Apply Q to D as D*QT +* + CALL ZTPMLQT('R','C',M,N,K,L,NB,AF(1,NP1),M,T,LDT,DF,M, + $ DF(1,NP1),M,WORK,INFO) + +* +* Compute |D*QT - D*QT| / |D| +* + CALL ZGEMM( 'N', 'C', M, N2, N2, -ONE, D, M, Q, N2, ONE, DF, M ) + RESID = ZLANGE( '1', M, N2, DF, M, RWORK ) + IF( CNORM.GT.ZERO ) THEN + RESULT( 6 ) = RESID / (EPS*MAX(1,N2)*DNORM) + ELSE + RESULT( 6 ) = ZERO + END IF +* +* Deallocate all arrays +* + DEALLOCATE ( A, AF, Q, R, RWORK, WORK, T, C, D, CF, DF) + RETURN + END
\ No newline at end of file diff --git a/TESTING/LIN/ztsqr01.f b/TESTING/LIN/ztsqr01.f new file mode 100644 index 00000000..5f39ae7e --- /dev/null +++ b/TESTING/LIN/ztsqr01.f @@ -0,0 +1,427 @@ +*> \brief \b ZTSQR01 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZTSQR01(TSSW, M,N, MB, NB, RESULT) +* +* .. Scalar Arguments .. +* INTEGER M, N, MB +* .. Return values .. +* DOUBLE PRECISION RESULT(6) +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZTSQR01 tests ZGEQR , ZGELQ, ZGEMLQ and ZGEMQR. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] TSSW +*> \verbatim +*> TSSW is CHARACTER +*> 'TS' for testing tall skinny QR +*> and anything else for testing short wide LQ +*> \endverbatim +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> Number of rows in test matrix. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> Number of columns in test matrix. +*> \endverbatim +*> \param[in] MB +*> \verbatim +*> MB is INTEGER +*> Number of row in row block in test matrix. +*> \endverbatim +*> +*> \param[in] NB +*> \verbatim +*> NB is INTEGER +*> Number of columns in column block test matrix. +*> \endverbatim +*> +*> \param[out] RESULT +*> \verbatim +*> RESULT is DOUBLE PRECISION array, dimension (6) +*> Results of each of the six tests below. +*> +*> RESULT(1) = | A - Q R | or | A - L Q | +*> RESULT(2) = | I - Q^H Q | or | I - Q Q^H | +*> RESULT(3) = | Q C - Q C | +*> RESULT(4) = | Q^H C - Q^H C | +*> RESULT(5) = | C Q - C Q | +*> RESULT(6) = | C Q^H - C Q^H | +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date April 2012 +* +* ===================================================================== + SUBROUTINE ZTSQR01(TSSW, M, N, MB, NB, RESULT) + IMPLICIT NONE +* +* -- LAPACK test routine (version 3.4.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* April 2012 +* +* .. Scalar Arguments .. + CHARACTER TSSW + INTEGER M, N, MB, NB +* .. Return values .. + DOUBLE PRECISION RESULT(6) +* +* ===================================================================== +* +* .. +* .. Local allocatable arrays + COMPLEX*16, ALLOCATABLE :: AF(:,:), Q(:,:), + $ R(:,:), RWORK(:), WORK( : ), T(:), + $ CF(:,:), DF(:,:), A(:,:), C(:,:), D(:,:), LQ(:,:) +* +* .. Parameters .. + DOUBLE PRECISION ZERO + COMPLEX*16 ONE, CZERO + PARAMETER( ZERO = 0.0, ONE = (1.0,0.0), CZERO=(0.0,0.0) ) +* .. +* .. Local Scalars .. + LOGICAL TESTZEROS, TS + INTEGER INFO, J, K, L, LWORK, LT ,MNB + DOUBLE PRECISION ANORM, EPS, RESID, CNORM, DNORM +* .. +* .. Local Arrays .. + INTEGER ISEED( 4 ) +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH, ZLANGE, ZLANSY + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL DLAMCH, ZLANGE, ZLANSY, LSAME, ILAENV +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. Scalars in Common .. + CHARACTER*32 srnamt +* .. +* .. Common blocks .. + COMMON / srnamc / srnamt +* .. +* .. Data statements .. + DATA ISEED / 1988, 1989, 1990, 1991 / +* +* TEST TALL SKINNY OR SHORT WIDE +* + TS = LSAME(TSSW, 'TS') +* +* TEST MATRICES WITH HALF OF MATRIX BEING ZEROS +* + TESTZEROS = .FALSE. +* + EPS = DLAMCH( 'Epsilon' ) + K = MIN(M,N) + L = MAX(M,N,1) + MNB = MAX ( MB, NB) + LWORK = MAX(3,L)*MNB + IF((K.GE.MNB).OR.(MNB.GE.L))THEN + LT=MAX(1,L)*MNB+5 + ELSE + LT=MAX(1,(L-K)/(MNB-K)+1)*L*MNB+5 + END IF + +* +* Dynamically allocate local arrays +* + ALLOCATE ( A(M,N), AF(M,N), Q(L,L), R(M,L), RWORK(L), + $ WORK(LWORK), T(LT), C(M,N), CF(M,N), + $ D(N,M), DF(N,M), LQ(L,N) ) +* +* Put random numbers into A and copy to AF +* + DO J=1,N + CALL ZLARNV( 2, ISEED, M, A( 1, J ) ) + END DO + IF (TESTZEROS) THEN + IF (M.GE.4) THEN + DO J=1,N + CALL ZLARNV( 2, ISEED, M/2, A( M/4, J ) ) + END DO + END IF + END IF + CALL ZLACPY( 'Full', M, N, A, M, AF, M ) +* + IF (TS) THEN +* +* Factor the matrix A in the array AF. +* + srnamt = 'ZGEQR' + CALL ZGEQR( M, N, AF, M, T, LT, WORK, LWORK, INFO ) +* +* Generate the m-by-m matrix Q +* + CALL ZLASET( 'Full', M, M, CZERO, ONE, Q, M ) + srnamt = 'ZGEMQR' + CALL ZGEMQR( 'L', 'N', M, M, K, AF, M, T, LT, Q, M, + $ WORK, LWORK, INFO ) +* +* Copy R +* + CALL ZLASET( 'Full', M, N, CZERO, CZERO, R, M ) + CALL ZLACPY( 'Upper', M, N, AF, M, R, M ) +* +* Compute |R - Q'*A| / |A| and store in RESULT(1) +* + CALL ZGEMM( 'C', 'N', M, N, M, -ONE, Q, M, A, M, ONE, R, M ) + ANORM = ZLANGE( '1', M, N, A, M, RWORK ) + RESID = ZLANGE( '1', M, N, R, M, RWORK ) + IF( ANORM.GT.ZERO ) THEN + RESULT( 1 ) = RESID / (EPS*MAX(1,M)*ANORM) + ELSE + RESULT( 1 ) = ZERO + END IF +* +* Compute |I - Q'*Q| and store in RESULT(2) +* + CALL ZLASET( 'Full', M, M, CZERO, ONE, R, M ) + CALL ZHERK( 'U', 'C', M, M, DREAL(-ONE), Q, M, DREAL(ONE), R, M ) + RESID = ZLANSY( '1', 'Upper', M, R, M, RWORK ) + RESULT( 2 ) = RESID / (EPS*MAX(1,M)) +* +* Generate random m-by-n matrix C and a copy CF +* + DO J=1,N + CALL ZLARNV( 2, ISEED, M, C( 1, J ) ) + END DO + CNORM = ZLANGE( '1', M, N, C, M, RWORK) + CALL ZLACPY( 'Full', M, N, C, M, CF, M ) +* +* Apply Q to C as Q*C +* + srnamt = 'ZGEMQR' + CALL ZGEMQR( 'L', 'N', M, N, K, AF, M, T, LT, CF, M, + $ WORK, LWORK, INFO) +* +* Compute |Q*C - Q*C| / |C| +* + CALL ZGEMM( 'N', 'N', M, N, M, -ONE, Q, M, C, M, ONE, CF, M ) + RESID = ZLANGE( '1', M, N, CF, M, RWORK ) + IF( CNORM.GT.ZERO ) THEN + RESULT( 3 ) = RESID / (EPS*MAX(1,M)*CNORM) + ELSE + RESULT( 3 ) = ZERO + END IF +* +* Copy C into CF again +* + CALL ZLACPY( 'Full', M, N, C, M, CF, M ) +* +* Apply Q to C as QT*C +* + srnamt = 'ZGEMQR' + CALL ZGEMQR( 'L', 'C', M, N, K, AF, M, T, LT, CF, M, + $ WORK, LWORK, INFO) +* +* Compute |QT*C - QT*C| / |C| +* + CALL ZGEMM( 'C', 'N', M, N, M, -ONE, Q, M, C, M, ONE, CF, M ) + RESID = ZLANGE( '1', M, N, CF, M, RWORK ) + IF( CNORM.GT.ZERO ) THEN + RESULT( 4 ) = RESID / (EPS*MAX(1,M)*CNORM) + ELSE + RESULT( 4 ) = ZERO + END IF +* +* Generate random n-by-m matrix D and a copy DF +* + DO J=1,M + CALL ZLARNV( 2, ISEED, N, D( 1, J ) ) + END DO + DNORM = ZLANGE( '1', N, M, D, N, RWORK) + CALL ZLACPY( 'Full', N, M, D, N, DF, N ) +* +* Apply Q to D as D*Q +* + srnamt = 'ZGEMQR' + CALL ZGEMQR( 'R', 'N', N, M, K, AF, M, T, LT, DF, N, + $ WORK, LWORK, INFO) +* +* Compute |D*Q - D*Q| / |D| +* + CALL ZGEMM( 'N', 'N', N, M, M, -ONE, D, N, Q, M, ONE, DF, N ) + RESID = ZLANGE( '1', N, M, DF, N, RWORK ) + IF( DNORM.GT.ZERO ) THEN + RESULT( 5 ) = RESID / (EPS*MAX(1,M)*DNORM) + ELSE + RESULT( 5 ) = ZERO + END IF +* +* Copy D into DF again +* + CALL ZLACPY( 'Full', N, M, D, N, DF, N ) +* +* Apply Q to D as D*QT +* + CALL ZGEMQR( 'R', 'C', N, M, K, AF, M, T, LT, DF, N, + $ WORK, LWORK, INFO) +* +* Compute |D*QT - D*QT| / |D| +* + CALL ZGEMM( 'N', 'C', N, M, M, -ONE, D, N, Q, M, ONE, DF, N ) + RESID = ZLANGE( '1', N, M, DF, N, RWORK ) + IF( CNORM.GT.ZERO ) THEN + RESULT( 6 ) = RESID / (EPS*MAX(1,M)*DNORM) + ELSE + RESULT( 6 ) = ZERO + END IF +* +* Short and wide +* + ELSE + srnamt = 'ZGELQ' + CALL ZGELQ( M, N, AF, M, T, LT, WORK, LWORK, INFO ) +* +* +* Generate the n-by-n matrix Q +* + CALL ZLASET( 'Full', N, N, CZERO, ONE, Q, N ) + srnamt = 'ZGEMLQ' + CALL ZGEMLQ( 'R', 'N', N, N, K, AF, M, T, LT, Q, N, + $ WORK, LWORK, INFO ) +* +* Copy R +* + CALL ZLASET( 'Full', M, N, CZERO, CZERO, LQ, L ) + CALL ZLACPY( 'Lower', M, N, AF, M, LQ, L ) +* +* Compute |L - A*Q'| / |A| and store in RESULT(1) +* + CALL ZGEMM( 'N', 'C', M, N, N, -ONE, A, M, Q, N, ONE, LQ, L ) + ANORM = ZLANGE( '1', M, N, A, M, RWORK ) + RESID = ZLANGE( '1', M, N, LQ, L, RWORK ) + IF( ANORM.GT.ZERO ) THEN + RESULT( 1 ) = RESID / (EPS*MAX(1,N)*ANORM) + ELSE + RESULT( 1 ) = ZERO + END IF +* +* Compute |I - Q'*Q| and store in RESULT(2) +* + CALL ZLASET( 'Full', N, N, CZERO, ONE, LQ, L ) + CALL ZHERK( 'U', 'C', N, N, DREAL(-ONE), Q, N, DREAL(ONE), LQ, L) + RESID = ZLANSY( '1', 'Upper', N, LQ, L, RWORK ) + RESULT( 2 ) = RESID / (EPS*MAX(1,N)) +* +* Generate random m-by-n matrix C and a copy CF +* + DO J=1,M + CALL ZLARNV( 2, ISEED, N, D( 1, J ) ) + END DO + DNORM = ZLANGE( '1', N, M, D, N, RWORK) + CALL ZLACPY( 'Full', N, M, D, N, DF, N ) +* +* Apply Q to C as Q*C +* + CALL ZGEMLQ( 'L', 'N', N, M, K, AF, M, T, LT, DF, N, + $ WORK, LWORK, INFO) +* +* Compute |Q*D - Q*D| / |D| +* + CALL ZGEMM( 'N', 'N', N, M, N, -ONE, Q, N, D, N, ONE, DF, N ) + RESID = ZLANGE( '1', N, M, DF, N, RWORK ) + IF( DNORM.GT.ZERO ) THEN + RESULT( 3 ) = RESID / (EPS*MAX(1,N)*DNORM) + ELSE + RESULT( 3 ) = ZERO + END IF +* +* Copy D into DF again +* + CALL ZLACPY( 'Full', N, M, D, N, DF, N ) +* +* Apply Q to D as QT*D +* + CALL ZGEMLQ( 'L', 'C', N, M, K, AF, M, T, LT, DF, N, + $ WORK, LWORK, INFO) +* +* Compute |QT*D - QT*D| / |D| +* + CALL ZGEMM( 'C', 'N', N, M, N, -ONE, Q, N, D, N, ONE, DF, N ) + RESID = ZLANGE( '1', N, M, DF, N, RWORK ) + IF( DNORM.GT.ZERO ) THEN + RESULT( 4 ) = RESID / (EPS*MAX(1,N)*DNORM) + ELSE + RESULT( 4 ) = ZERO + END IF +* +* Generate random n-by-m matrix D and a copy DF +* + DO J=1,N + CALL ZLARNV( 2, ISEED, M, C( 1, J ) ) + END DO + CNORM = ZLANGE( '1', M, N, C, M, RWORK) + CALL ZLACPY( 'Full', M, N, C, M, CF, M ) +* +* Apply Q to C as C*Q +* + CALL ZGEMLQ( 'R', 'N', M, N, K, AF, M, T, LT, CF, M, + $ WORK, LWORK, INFO) +* +* Compute |C*Q - C*Q| / |C| +* + CALL ZGEMM( 'N', 'N', M, N, N, -ONE, C, M, Q, N, ONE, CF, M ) + RESID = ZLANGE( '1', N, M, DF, N, RWORK ) + IF( CNORM.GT.ZERO ) THEN + RESULT( 5 ) = RESID / (EPS*MAX(1,N)*CNORM) + ELSE + RESULT( 5 ) = ZERO + END IF +* +* Copy C into CF again +* + CALL ZLACPY( 'Full', M, N, C, M, CF, M ) +* +* Apply Q to D as D*QT +* + CALL ZGEMLQ( 'R', 'C', M, N, K, AF, M, T, LT, CF, M, + $ WORK, LWORK, INFO) +* +* Compute |C*QT - C*QT| / |C| +* + CALL ZGEMM( 'N', 'C', M, N, N, -ONE, C, M, Q, N, ONE, CF, M ) + RESID = ZLANGE( '1', M, N, CF, M, RWORK ) + IF( CNORM.GT.ZERO ) THEN + RESULT( 6 ) = RESID / (EPS*MAX(1,N)*CNORM) + ELSE + RESULT( 6 ) = ZERO + END IF +* + END IF +* +* Deallocate all arrays +* + DEALLOCATE ( A, AF, Q, R, RWORK, WORK, T, C, D, CF, DF) +* + RETURN + END
\ No newline at end of file diff --git a/TESTING/ctest.in b/TESTING/ctest.in index 95a7b0dd..b8a197a9 100644..100755 --- a/TESTING/ctest.in +++ b/TESTING/ctest.in @@ -42,3 +42,6 @@ CLS 6 List types on next line if 0 < NTYPES < 6 CEQ CQT CQX +CXQ +CTQ +CTS diff --git a/TESTING/dtest.in b/TESTING/dtest.in index a2343db1..fd061441 100644..100755 --- a/TESTING/dtest.in +++ b/TESTING/dtest.in @@ -39,3 +39,6 @@ DLS 6 List types on next line if 0 < NTYPES < 6 DEQ DQT DQX +DXQ +DTQ +DTS
\ No newline at end of file diff --git a/TESTING/stest.in b/TESTING/stest.in index 865adfb7..16529646 100644..100755 --- a/TESTING/stest.in +++ b/TESTING/stest.in @@ -39,3 +39,6 @@ SLS 6 List types on next line if 0 < NTYPES < 6 SEQ SQT SQX +SXQ +STQ +STS diff --git a/TESTING/ztest.in b/TESTING/ztest.in index 72a51351..f3eabb5e 100644..100755 --- a/TESTING/ztest.in +++ b/TESTING/ztest.in @@ -42,3 +42,6 @@ ZLS 6 List types on next line if 0 < NTYPES < 6 ZEQ ZQT ZQX +ZXQ +ZTQ +ZTS |