Martin Kroeker
GitHub
6 years ago
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
34 changed files with 3454 additions and 196 deletions
Split View
Diff Options
-
+8 -4lapack-netlib/TESTING/LIN/CMakeLists.txt
-
+38 -37lapack-netlib/TESTING/LIN/Makefile
-
+27 -13lapack-netlib/TESTING/LIN/cchkaa.f
-
+239 -0lapack-netlib/TESTING/LIN/cchkunhr_col.f
-
+13 -12lapack-netlib/TESTING/LIN/cdrvls.f
-
+2 -1lapack-netlib/TESTING/LIN/cdrvsy_rk.f
-
+164 -0lapack-netlib/TESTING/LIN/cerrunhr_col.f
-
+2 -2lapack-netlib/TESTING/LIN/cerrvx.f
-
+1 -1lapack-netlib/TESTING/LIN/clahilb.f
-
+13 -13lapack-netlib/TESTING/LIN/ctsqr01.f
-
+390 -0lapack-netlib/TESTING/LIN/cunhr_col01.f
-
+27 -12lapack-netlib/TESTING/LIN/dchkaa.f
-
+239 -0lapack-netlib/TESTING/LIN/dchkorhr_col.f
-
+8 -8lapack-netlib/TESTING/LIN/ddrvls.f
-
+164 -0lapack-netlib/TESTING/LIN/derrorhr_col.f
-
+1 -1lapack-netlib/TESTING/LIN/derrvx.f
-
+386 -0lapack-netlib/TESTING/LIN/dorhr_col01.f
-
+13 -13lapack-netlib/TESTING/LIN/dtsqr01.f
-
+24 -11lapack-netlib/TESTING/LIN/schkaa.f
-
+239 -0lapack-netlib/TESTING/LIN/schkorhr_col.f
-
+10 -10lapack-netlib/TESTING/LIN/sdrvls.f
-
+164 -0lapack-netlib/TESTING/LIN/serrorhr_col.f
-
+1 -1lapack-netlib/TESTING/LIN/serrvx.f
-
+386 -0lapack-netlib/TESTING/LIN/sorhr_col01.f
-
+13 -13lapack-netlib/TESTING/LIN/stsqr01.f
-
+28 -15lapack-netlib/TESTING/LIN/zchkaa.f
-
+239 -0lapack-netlib/TESTING/LIN/zchkunhr_col.f
-
+1 -0lapack-netlib/TESTING/LIN/zdrvhe_rk.f
-
+13 -12lapack-netlib/TESTING/LIN/zdrvls.f
-
+164 -0lapack-netlib/TESTING/LIN/zerrunhr_col.f
-
+33 -3lapack-netlib/TESTING/LIN/zerrvx.f
-
+1 -1lapack-netlib/TESTING/LIN/zlahilb.f
-
+13 -13lapack-netlib/TESTING/LIN/ztsqr01.f
-
+390 -0lapack-netlib/TESTING/LIN/zunhr_col01.f
+ 8
- 4
lapack-netlib/TESTING/LIN/CMakeLists.txt
View File
| @@ -39,7 +39,8 @@ set(SLINTST schkaa.f | |||
| strt02.f strt03.f strt05.f strt06.f | |||
| sgennd.f sqrt04.f sqrt05.f schkqrt.f serrqrt.f schkqrtp.f serrqrtp.f | |||
| schklqt.f schklqtp.f schktsqr.f | |||
| serrlqt.f serrlqtp.f serrtsqr.f stsqr01.f slqt04.f slqt05.f) | |||
| serrlqt.f serrlqtp.f serrtsqr.f stsqr01.f slqt04.f slqt05.f | |||
| schkorhr_col.f serrorhr_col.f sorhr_col01.f) | |||
| if(USE_XBLAS) | |||
| list(APPEND SLINTST sdrvgbx.f sdrvgex.f sdrvsyx.f sdrvpox.f | |||
| @@ -94,7 +95,8 @@ set(CLINTST cchkaa.f | |||
| sget06.f cgennd.f | |||
| cqrt04.f cqrt05.f cchkqrt.f cerrqrt.f cchkqrtp.f cerrqrtp.f | |||
| cchklqt.f cchklqtp.f cchktsqr.f | |||
| cerrlqt.f cerrlqtp.f cerrtsqr.f ctsqr01.f clqt04.f clqt05.f) | |||
| cerrlqt.f cerrlqtp.f cerrtsqr.f ctsqr01.f clqt04.f clqt05.f | |||
| cchkunhr_col.f cerrunhr_col.f cunhr_col01.f) | |||
| if(USE_XBLAS) | |||
| list(APPEND CLINTST cdrvgbx.f cdrvgex.f cdrvhex.f cdrvsyx.f cdrvpox.f | |||
| @@ -139,7 +141,8 @@ set(DLINTST dchkaa.f | |||
| dgennd.f | |||
| dqrt04.f dqrt05.f dchkqrt.f derrqrt.f dchkqrtp.f derrqrtp.f | |||
| dchklq.f dchklqt.f dchklqtp.f dchktsqr.f | |||
| derrlqt.f derrlqtp.f derrtsqr.f dtsqr01.f dlqt04.f dlqt05.f) | |||
| derrlqt.f derrlqtp.f derrtsqr.f dtsqr01.f dlqt04.f dlqt05.f | |||
| dchkorhr_col.f derrorhr_col.f dorhr_col01.f) | |||
| if(USE_XBLAS) | |||
| list(APPEND DLINTST ddrvgbx.f ddrvgex.f ddrvsyx.f ddrvpox.f | |||
| @@ -194,7 +197,8 @@ set(ZLINTST zchkaa.f | |||
| dget06.f zgennd.f | |||
| zqrt04.f zqrt05.f zchkqrt.f zerrqrt.f zchkqrtp.f zerrqrtp.f | |||
| zchklqt.f zchklqtp.f zchktsqr.f | |||
| zerrlqt.f zerrlqtp.f zerrtsqr.f ztsqr01.f zlqt04.f zlqt05.f) | |||
| zerrlqt.f zerrlqtp.f zerrtsqr.f ztsqr01.f zlqt04.f zlqt05.f | |||
| zchkunhr_col.f zerrunhr_col.f zunhr_col01.f) | |||
| if(USE_XBLAS) | |||
| list(APPEND ZLINTST zdrvgbx.f zdrvgex.f zdrvhex.f zdrvsyx.f zdrvpox.f | |||
+ 38
- 37
lapack-netlib/TESTING/LIN/Makefile
View File
| @@ -1,5 +1,3 @@ | |||
| include ../../make.inc | |||
| ####################################################################### | |||
| # This makefile creates the test programs for the linear equation | |||
| # routines in LAPACK. The test files are grouped as follows: | |||
| @@ -33,10 +31,8 @@ include ../../make.inc | |||
| # | |||
| ####################################################################### | |||
| ifneq ($(strip $(VARLIB)),) | |||
| LAPACKLIB := $(VARLIB) ../../$(LAPACKLIB) | |||
| endif | |||
| TOPSRCDIR = ../.. | |||
| include $(TOPSRCDIR)/make.inc | |||
| ALINTST = \ | |||
| aladhd.o alaerh.o alaesm.o alahd.o alareq.o \ | |||
| @@ -77,7 +73,8 @@ SLINTST = schkaa.o \ | |||
| strt02.o strt03.o strt05.o strt06.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 | |||
| serrlqt.o serrlqtp.o serrtsqr.o stsqr01.o slqt04.o slqt05.o \ | |||
| schkorhr_col.o serrorhr_col.o sorhr_col01.o | |||
| ifdef USEXBLAS | |||
| SLINTST += sdrvgbx.o sdrvgex.o sdrvsyx.o sdrvpox.o \ | |||
| @@ -125,7 +122,8 @@ CLINTST = cchkaa.o \ | |||
| sget06.o cgennd.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 | |||
| cerrlqt.o cerrlqtp.o cerrtsqr.o ctsqr01.o clqt04.o clqt05.o \ | |||
| cchkunhr_col.o cerrunhr_col.o cunhr_col01.o | |||
| ifdef USEXBLAS | |||
| CLINTST += cdrvgbx.o cdrvgex.o cdrvhex.o cdrvsyx.o cdrvpox.o \ | |||
| @@ -168,7 +166,8 @@ DLINTST = dchkaa.o \ | |||
| dgennd.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 | |||
| derrlqt.o derrlqtp.o derrtsqr.o dtsqr01.o dlqt04.o dlqt05.o \ | |||
| dchkorhr_col.o derrorhr_col.o dorhr_col01.o | |||
| ifdef USEXBLAS | |||
| DLINTST += ddrvgbx.o ddrvgex.o ddrvsyx.o ddrvpox.o \ | |||
| @@ -215,7 +214,8 @@ ZLINTST = zchkaa.o \ | |||
| dget06.o zgennd.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 | |||
| zerrlqt.o zerrlqtp.o zerrtsqr.o ztsqr01.o zlqt04.o zlqt05.o \ | |||
| zchkunhr_col.o zerrunhr_col.o zunhr_col01.o | |||
| ifdef USEXBLAS | |||
| ZLINTST += zdrvgbx.o zdrvgex.o zdrvhex.o zdrvsyx.o zdrvpox.o \ | |||
| @@ -254,47 +254,50 @@ ZLINTSTRFP = zchkrfp.o zdrvrfp.o zdrvrf1.o zdrvrf2.o zdrvrf3.o zdrvrf4.o zerrrfp | |||
| 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 | |||
| .PHONY: all | |||
| all: single double complex complex16 proto-single proto-double proto-complex proto-complex16 | |||
| .PHONY: single double complex complex16 | |||
| single: xlintsts | |||
| double: xlintstd | |||
| complex: xlintstc | |||
| complex16: xlintstz | |||
| .PHONY: proto-single proto-double proto-complex proto-complex16 | |||
| proto-single: xlintstrfs | |||
| proto-double: xlintstds xlintstrfd | |||
| proto-complex: xlintstrfc | |||
| proto-complex16: xlintstzc xlintstrfz | |||
| xlintsts: $(ALINTST) $(SLINTST) $(SCLNTST) ../../$(TMGLIB) ../../$(LAPACKLIB) $(XBLASLIB) $(BLASLIB) | |||
| $(LOADER) $(LOADOPTS) -o $@ $^ | |||
| xlintsts: $(ALINTST) $(SLINTST) $(SCLNTST) $(TMGLIB) $(VARLIB) $(LAPACKLIB) $(XBLASLIB) $(BLASLIB) | |||
| $(FC) $(FFLAGS) $(LDFLAGS) -o $@ $^ | |||
| xlintstc: $(ALINTST) $(CLINTST) $(SCLNTST) ../../$(TMGLIB) ../../$(LAPACKLIB) $(XBLASLIB) $(BLASLIB) | |||
| $(LOADER) $(LOADOPTS) -o $@ $^ | |||
| xlintstc: $(ALINTST) $(CLINTST) $(SCLNTST) $(TMGLIB) $(VARLIB) $(LAPACKLIB) $(XBLASLIB) $(BLASLIB) | |||
| $(FC) $(FFLAGS) $(LDFLAGS) -o $@ $^ | |||
| xlintstd: $(ALINTST) $(DLINTST) $(DZLNTST) ../../$(TMGLIB) ../../$(LAPACKLIB) $(XBLASLIB) $(BLASLIB) | |||
| $(LOADER) $(LOADOPTS) -o $@ $^ | |||
| xlintstd: $(ALINTST) $(DLINTST) $(DZLNTST) $(TMGLIB) $(VARLIB) $(LAPACKLIB) $(XBLASLIB) $(BLASLIB) | |||
| $(FC) $(FFLAGS) $(LDFLAGS) -o $@ $^ | |||
| xlintstz: $(ALINTST) $(ZLINTST) $(DZLNTST) ../../$(TMGLIB) ../../$(LAPACKLIB) $(XBLASLIB) $(BLASLIB) | |||
| $(LOADER) $(LOADOPTS) -o $@ $^ | |||
| xlintstz: $(ALINTST) $(ZLINTST) $(DZLNTST) $(TMGLIB) $(VARLIB) $(LAPACKLIB) $(XBLASLIB) $(BLASLIB) | |||
| $(FC) $(FFLAGS) $(LDFLAGS) -o $@ $^ | |||
| xlintstds: $(DSLINTST) ../../$(TMGLIB) ../../$(LAPACKLIB) $(BLASLIB) | |||
| $(LOADER) $(LOADOPTS) -o $@ $^ | |||
| xlintstds: $(DSLINTST) $(TMGLIB) $(VARLIB) $(LAPACKLIB) $(BLASLIB) | |||
| $(FC) $(FFLAGS) $(LDFLAGS) -o $@ $^ | |||
| xlintstzc: $(ZCLINTST) ../../$(TMGLIB) ../../$(LAPACKLIB) $(BLASLIB) | |||
| $(LOADER) $(LOADOPTS) -o $@ $^ | |||
| xlintstzc: $(ZCLINTST) $(TMGLIB) $(VARLIB) $(LAPACKLIB) $(BLASLIB) | |||
| $(FC) $(FFLAGS) $(LDFLAGS) -o $@ $^ | |||
| xlintstrfs: $(SLINTSTRFP) ../../$(TMGLIB) ../../$(LAPACKLIB) $(BLASLIB) | |||
| $(LOADER) $(LOADOPTS) -o $@ $^ | |||
| xlintstrfs: $(SLINTSTRFP) $(TMGLIB) $(VARLIB) $(LAPACKLIB) $(BLASLIB) | |||
| $(FC) $(FFLAGS) $(LDFLAGS) -o $@ $^ | |||
| xlintstrfd: $(DLINTSTRFP) ../../$(TMGLIB) ../../$(LAPACKLIB) $(BLASLIB) | |||
| $(LOADER) $(LOADOPTS) -o $@ $^ | |||
| xlintstrfd: $(DLINTSTRFP) $(TMGLIB) $(VARLIB) $(LAPACKLIB) $(BLASLIB) | |||
| $(FC) $(FFLAGS) $(LDFLAGS) -o $@ $^ | |||
| xlintstrfc: $(CLINTSTRFP) ../../$(TMGLIB) ../../$(LAPACKLIB) $(BLASLIB) | |||
| $(LOADER) $(LOADOPTS) -o $@ $^ | |||
| xlintstrfc: $(CLINTSTRFP) $(TMGLIB) $(VARLIB) $(LAPACKLIB) $(BLASLIB) | |||
| $(FC) $(FFLAGS) $(LDFLAGS) -o $@ $^ | |||
| xlintstrfz: $(ZLINTSTRFP) ../../$(TMGLIB) ../../$(LAPACKLIB) $(BLASLIB) | |||
| $(LOADER) $(LOADOPTS) -o $@ $^ | |||
| xlintstrfz: $(ZLINTSTRFP) $(TMGLIB) $(VARLIB) $(LAPACKLIB) $(BLASLIB) | |||
| $(FC) $(FFLAGS) $(LDFLAGS) -o $@ $^ | |||
| $(ALINTST): $(FRC) | |||
| $(SCLNTST): $(FRC) | |||
| @@ -307,6 +310,7 @@ $(ZLINTST): $(FRC) | |||
| FRC: | |||
| @FRC=$(FRC) | |||
| .PHONY: clean cleanobj cleanexe | |||
| clean: cleanobj cleanexe | |||
| cleanobj: | |||
| rm -f *.o | |||
| @@ -314,15 +318,12 @@ cleanexe: | |||
| rm -f xlintst* | |||
| schkaa.o: schkaa.f | |||
| $(FORTRAN) $(DRVOPTS) -c -o $@ $< | |||
| $(FC) $(FFLAGS_DRV) -c -o $@ $< | |||
| dchkaa.o: dchkaa.f | |||
| $(FORTRAN) $(DRVOPTS) -c -o $@ $< | |||
| $(FC) $(FFLAGS_DRV) -c -o $@ $< | |||
| cchkaa.o: cchkaa.f | |||
| $(FORTRAN) $(DRVOPTS) -c -o $@ $< | |||
| $(FC) $(FFLAGS_DRV) -c -o $@ $< | |||
| zchkaa.o: zchkaa.f | |||
| $(FORTRAN) $(DRVOPTS) -c -o $@ $< | |||
| .f.o: | |||
| $(FORTRAN) $(OPTS) -c -o $@ $< | |||
| $(FC) $(FFLAGS_DRV) -c -o $@ $< | |||
| .NOTPARALLEL: | |||
+ 27
- 13
lapack-netlib/TESTING/LIN/cchkaa.f
View File
| @@ -74,6 +74,8 @@ | |||
| *> CEQ | |||
| *> CQT | |||
| *> CQX | |||
| *> CTS | |||
| *> CHH | |||
| *> \endverbatim | |||
| * | |||
| * Parameters: | |||
| @@ -108,14 +110,14 @@ | |||
| *> \author Univ. of Colorado Denver | |||
| *> \author NAG Ltd. | |||
| * | |||
| *> \date November 2017 | |||
| *> \date November 2019 | |||
| * | |||
| *> \ingroup complex_lin | |||
| * | |||
| * ===================================================================== | |||
| PROGRAM CCHKAA | |||
| * | |||
| * -- LAPACK test routine (version 3.8.0) -- | |||
| * -- LAPACK test routine (version 3.9.0) -- | |||
| * -- LAPACK is a software package provided by Univ. of Tennessee, -- | |||
| * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- | |||
| * November 2017 | |||
| @@ -165,15 +167,16 @@ | |||
| * .. | |||
| * .. External Subroutines .. | |||
| EXTERNAL ALAREQ, CCHKEQ, CCHKGB, CCHKGE, CCHKGT, CCHKHE, | |||
| $ CCHKHE_ROOK, CCHKHE_RK, CCHKHE_AA, CCHKLQ, | |||
| $ CCHKPB,CCHKPO, CCHKPS, CCHKPP, CCHKPT, CCHKQ3, | |||
| $ CCHKQL, CCHKQR, CCHKRQ, CCHKSP, CCHKSY, | |||
| $ CCHKSY_ROOK, CCHKSY_RK, CCHKSY_AA, CCHKTB, | |||
| $ CCHKTP, CCHKTR, CCHKTZ, CDRVGB, CDRVGE, CDRVGT, | |||
| $ CDRVHE, CDRVHE_ROOK, CDRVHE_RK, CDRVHE_AA, | |||
| $ CDRVHP, CDRVLS, CDRVPB, CDRVPO, CDRVPP, CDRVPT, | |||
| $ CDRVSP, CDRVSY, CDRVSY_ROOK, CDRVSY_RK, | |||
| $ CDRVSY_AA, ILAVER, CCHKQRT, CCHKQRTP | |||
| $ CCHKHE_ROOK, CCHKHE_RK, CCHKHE_AA, CCHKHP, | |||
| $ CCHKLQ, CCHKUNHR_COL, CCHKPB, CCHKPO, CCHKPS, | |||
| $ CCHKPP, CCHKPT, CCHKQ3, CCHKQL, CCHKQR, CCHKRQ, | |||
| $ CCHKSP, CCHKSY, CCHKSY_ROOK, CCHKSY_RK, | |||
| $ CCHKSY_AA, CCHKTB, CCHKTP, CCHKTR, CCHKTZ, | |||
| $ CDRVGB, CDRVGE, CDRVGT, CDRVHE, CDRVHE_ROOK, | |||
| $ CDRVHE_RK, CDRVHE_AA, CDRVHP, CDRVLS, CDRVPB, | |||
| $ CDRVPO, CDRVPP, CDRVPT, CDRVSP, CDRVSY, | |||
| $ CDRVSY_ROOK, CDRVSY_RK, CDRVSY_AA, ILAVER, | |||
| $ CCHKQRT, CCHKQRTP | |||
| * .. | |||
| * .. Scalars in Common .. | |||
| LOGICAL LERR, OK | |||
| @@ -678,7 +681,7 @@ | |||
| * | |||
| * HK: Hermitian indefinite matrices, | |||
| * with bounded Bunch-Kaufman (rook) pivoting algorithm, | |||
| * differnet matrix storage format than HR path version. | |||
| * different matrix storage format than HR path version. | |||
| * | |||
| NTYPES = 10 | |||
| CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) | |||
| @@ -838,7 +841,7 @@ | |||
| * | |||
| * SK: symmetric indefinite matrices, | |||
| * with bounded Bunch-Kaufman (rook) pivoting algorithm, | |||
| * differnet matrix storage format than SR path version. | |||
| * different matrix storage format than SR path version. | |||
| * | |||
| NTYPES = 11 | |||
| CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) | |||
| @@ -1165,6 +1168,17 @@ | |||
| ELSE | |||
| WRITE( NOUT, FMT = 9989 )PATH | |||
| END IF | |||
| * | |||
| ELSE IF( LSAMEN( 2, C2, 'HH' ) ) THEN | |||
| * | |||
| * HH: Householder reconstruction for tall-skinny matrices | |||
| * | |||
| IF( TSTCHK ) THEN | |||
| CALL CCHKUNHR_COL( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, | |||
| $ NBVAL, NOUT ) | |||
| ELSE | |||
| WRITE( NOUT, FMT = 9989 ) PATH | |||
| END IF | |||
| * | |||
| ELSE | |||
| * | |||
+ 239
- 0
lapack-netlib/TESTING/LIN/cchkunhr_col.f
View File
| @@ -0,0 +1,239 @@ | |||
| *> \brief \b CCHKUNHR_COL | |||
| * | |||
| * =========== DOCUMENTATION =========== | |||
| * | |||
| * Online html documentation available at | |||
| * http://www.netlib.org/lapack/explore-html/ | |||
| * | |||
| * Definition: | |||
| * =========== | |||
| * | |||
| * SUBROUTINE CCHKUNHR_COL( 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 | |||
| *> | |||
| *> CCHKUNHR_COL tests CUNHR_COL using CLATSQR and CGEMQRT. Therefore, CLATSQR | |||
| *> (used in CGEQR) and CGEMQRT (used in CGEMQR) have to be tested | |||
| *> before this test. | |||
| *> | |||
| *> \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 2019 | |||
| * | |||
| *> \ingroup complex_lin | |||
| * | |||
| * ===================================================================== | |||
| SUBROUTINE CCHKUNHR_COL( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, | |||
| $ NBVAL, NOUT ) | |||
| IMPLICIT NONE | |||
| * | |||
| * -- LAPACK test routine (version 3.7.0) -- | |||
| * -- LAPACK is a software package provided by Univ. of Tennessee, -- | |||
| * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- | |||
| * December 2016 | |||
| * | |||
| * .. 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(LEN=3) PATH | |||
| INTEGER I, IMB1, INB1, INB2, J, T, M, N, MB1, NB1, | |||
| $ NB2, NFAIL, NERRS, NRUN | |||
| * | |||
| * .. Local Arrays .. | |||
| REAL RESULT( NTESTS ) | |||
| * .. | |||
| * .. External Subroutines .. | |||
| EXTERNAL ALAHD, ALASUM, CERRUNHR_COL, CUNHR_COL01 | |||
| * .. | |||
| * .. Intrinsic Functions .. | |||
| INTRINSIC MAX, MIN | |||
| * .. | |||
| * .. Scalars in Common .. | |||
| LOGICAL LERR, OK | |||
| CHARACTER(LEN=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 ) = 'HH' | |||
| NRUN = 0 | |||
| NFAIL = 0 | |||
| NERRS = 0 | |||
| * | |||
| * Test the error exits | |||
| * | |||
| IF( TSTERR ) CALL CERRUNHR_COL( 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 ) | |||
| * | |||
| * Only for M >= N | |||
| * | |||
| IF ( MIN( M, N ).GT.0 .AND. M.GE.N ) THEN | |||
| * | |||
| * Do for each possible value of MB1 | |||
| * | |||
| DO IMB1 = 1, NNB | |||
| MB1 = NBVAL( IMB1 ) | |||
| * | |||
| * Only for MB1 > N | |||
| * | |||
| IF ( MB1.GT.N ) THEN | |||
| * | |||
| * Do for each possible value of NB1 | |||
| * | |||
| DO INB1 = 1, NNB | |||
| NB1 = NBVAL( INB1 ) | |||
| * | |||
| * Do for each possible value of NB2 | |||
| * | |||
| DO INB2 = 1, NNB | |||
| NB2 = NBVAL( INB2 ) | |||
| * | |||
| IF( NB1.GT.0 .AND. NB2.GT.0 ) THEN | |||
| * | |||
| * Test CUNHR_COL | |||
| * | |||
| CALL CUNHR_COL01( M, N, MB1, NB1, NB2, | |||
| $ 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, MB1, | |||
| $ NB1, NB2, T, RESULT( T ) | |||
| NFAIL = NFAIL + 1 | |||
| END IF | |||
| END DO | |||
| NRUN = NRUN + NTESTS | |||
| END IF | |||
| END DO | |||
| END DO | |||
| END IF | |||
| END DO | |||
| END IF | |||
| END DO | |||
| END DO | |||
| * | |||
| * Print a summary of the results. | |||
| * | |||
| CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) | |||
| * | |||
| 9999 FORMAT( 'M=', I5, ', N=', I5, ', MB1=', I5, | |||
| $ ', NB1=', I5, ', NB2=', I5,' test(', I2, ')=', G12.5 ) | |||
| RETURN | |||
| * | |||
| * End of CCHKUNHR_COL | |||
| * | |||
| END | |||
+ 13
- 12
lapack-netlib/TESTING/LIN/cdrvls.f
View File
| @@ -237,13 +237,13 @@ | |||
| REAL EPS, NORMA, NORMB, RCOND | |||
| * .. | |||
| * .. Local Arrays .. | |||
| INTEGER ISEED( 4 ), ISEEDY( 4 ), IWQ | |||
| REAL RESULT( NTESTS ), RWQ | |||
| COMPLEX WQ | |||
| INTEGER ISEED( 4 ), ISEEDY( 4 ), IWQ( 1 ) | |||
| REAL RESULT( NTESTS ), RWQ( 1 ) | |||
| COMPLEX WQ( 1 ) | |||
| * .. | |||
| * .. Allocatable Arrays .. | |||
| COMPLEX, ALLOCATABLE :: WORK (:) | |||
| REAL, ALLOCATABLE :: RWORK (:) | |||
| REAL, ALLOCATABLE :: RWORK (:), WORK2 (:) | |||
| INTEGER, ALLOCATABLE :: IWORK (:) | |||
| * .. | |||
| * .. External Functions .. | |||
| @@ -363,32 +363,32 @@ | |||
| * Compute workspace needed for CGELS | |||
| CALL CGELS( TRANS, M, N, NRHS, A, LDA, | |||
| $ B, LDB, WQ, -1, INFO ) | |||
| LWORK_CGELS = INT( WQ ) | |||
| LWORK_CGELS = INT( WQ( 1 ) ) | |||
| * Compute workspace needed for CGETSLS | |||
| CALL CGETSLS( TRANS, M, N, NRHS, A, LDA, | |||
| $ B, LDB, WQ, -1, INFO ) | |||
| LWORK_CGETSLS = INT( WQ ) | |||
| LWORK_CGETSLS = INT( WQ( 1 ) ) | |||
| ENDDO | |||
| END IF | |||
| * Compute workspace needed for CGELSY | |||
| CALL CGELSY( M, N, NRHS, A, LDA, B, LDB, | |||
| $ IWQ, RCOND, CRANK, WQ, -1, RWORK, | |||
| $ INFO ) | |||
| LWORK_CGELSY = INT( WQ ) | |||
| LWORK_CGELSY = INT( WQ( 1 ) ) | |||
| LRWORK_CGELSY = 2*N | |||
| * Compute workspace needed for CGELSS | |||
| CALL CGELSS( M, N, NRHS, A, LDA, B, LDB, S, | |||
| $ RCOND, CRANK, WQ, -1, RWORK, INFO ) | |||
| LWORK_CGELSS = INT( WQ ) | |||
| LWORK_CGELSS = INT( WQ( 1 ) ) | |||
| LRWORK_CGELSS = 5*MNMIN | |||
| * Compute workspace needed for CGELSD | |||
| CALL CGELSD( M, N, NRHS, A, LDA, B, LDB, S, | |||
| $ RCOND, CRANK, WQ, -1, RWQ, IWQ, | |||
| $ INFO ) | |||
| LWORK_CGELSD = INT( WQ ) | |||
| LRWORK_CGELSD = INT( RWQ ) | |||
| LWORK_CGELSD = INT( WQ( 1 ) ) | |||
| LRWORK_CGELSD = INT( RWQ ( 1 ) ) | |||
| * Compute LIWORK workspace needed for CGELSY and CGELSD | |||
| LIWORK = MAX( LIWORK, N, IWQ ) | |||
| LIWORK = MAX( LIWORK, N, IWQ ( 1 ) ) | |||
| * Compute LRWORK workspace needed for CGELSY, CGELSS and CGELSD | |||
| LRWORK = MAX( LRWORK, LRWORK_CGELSY, | |||
| $ LRWORK_CGELSS, LRWORK_CGELSD ) | |||
| @@ -408,6 +408,7 @@ | |||
| ALLOCATE( WORK( LWORK ) ) | |||
| ALLOCATE( IWORK( LIWORK ) ) | |||
| ALLOCATE( RWORK( LRWORK ) ) | |||
| ALLOCATE( WORK2( 2 * LWORK ) ) | |||
| * | |||
| DO 140 IM = 1, NM | |||
| M = MVAL( IM ) | |||
| @@ -596,7 +597,7 @@ | |||
| $ CALL CLACPY( 'Full', NROWS, NRHS, | |||
| $ COPYB, LDB, C, LDB ) | |||
| CALL CQRT16( TRANS, M, N, NRHS, COPYA, | |||
| $ LDA, B, LDB, C, LDB, WORK, | |||
| $ LDA, B, LDB, C, LDB, WORK2, | |||
| $ RESULT( 15 ) ) | |||
| * | |||
| IF( ( ITRAN.EQ.1 .AND. M.GE.N ) .OR. | |||
+ 2
- 1
lapack-netlib/TESTING/LIN/cdrvsy_rk.f
View File
| @@ -98,8 +98,9 @@ | |||
| *> \param[out] E | |||
| *> \verbatim | |||
| *> E is COMPLEX array, dimension (NMAX) | |||
| *> \param[out] AINV | |||
| *> \endverbatim | |||
| *> | |||
| *> \param[out] AINV | |||
| *> \verbatim | |||
| *> AINV is COMPLEX array, dimension (NMAX*NMAX) | |||
| *> \endverbatim | |||
+ 164
- 0
lapack-netlib/TESTING/LIN/cerrunhr_col.f
View File
| @@ -0,0 +1,164 @@ | |||
| *> \brief \b CERRUNHR_COL | |||
| * | |||
| * =========== DOCUMENTATION =========== | |||
| * | |||
| * Online html documentation available at | |||
| * http://www.netlib.org/lapack/explore-html/ | |||
| * | |||
| * Definition: | |||
| * =========== | |||
| * | |||
| * SUBROUTINE CERRUNHR_COL( PATH, NUNIT ) | |||
| * | |||
| * .. Scalar Arguments .. | |||
| * CHARACTER*3 PATH | |||
| * INTEGER NUNIT | |||
| * .. | |||
| * | |||
| * | |||
| *> \par Purpose: | |||
| * ============= | |||
| *> | |||
| *> \verbatim | |||
| *> | |||
| *> CERRUNHR_COL tests the error exits for CUNHR_COL that does | |||
| *> Householder reconstruction from the ouput of tall-skinny | |||
| *> factorization CLATSQR. | |||
| *> \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 2019 | |||
| * | |||
| *> \ingroup complex_lin | |||
| * | |||
| * ===================================================================== | |||
| SUBROUTINE CERRUNHR_COL( PATH, NUNIT ) | |||
| IMPLICIT NONE | |||
| * | |||
| * -- LAPACK test routine (version 3.9.0) -- | |||
| * -- LAPACK is a software package provided by Univ. of Tennessee, -- | |||
| * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- | |||
| * November 2019 | |||
| * | |||
| * .. Scalar Arguments .. | |||
| CHARACTER(LEN=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 ), D(NMAX) | |||
| * .. | |||
| * .. External Subroutines .. | |||
| EXTERNAL ALAESM, CHKXER, CUNHR_COL | |||
| * .. | |||
| * .. Scalars in Common .. | |||
| LOGICAL LERR, OK | |||
| CHARACTER(LEN=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 ) = CMPLX( 1.E+0 / REAL( I+J ) ) | |||
| T( I, J ) = CMPLX( 1.E+0 / REAL( I+J ) ) | |||
| END DO | |||
| D( J ) = ( 0.E+0, 0.E+0 ) | |||
| END DO | |||
| OK = .TRUE. | |||
| * | |||
| * Error exits for Householder reconstruction | |||
| * | |||
| * CUNHR_COL | |||
| * | |||
| SRNAMT = 'CUNHR_COL' | |||
| * | |||
| INFOT = 1 | |||
| CALL CUNHR_COL( -1, 0, 1, A, 1, T, 1, D, INFO ) | |||
| CALL CHKXER( 'CUNHR_COL', INFOT, NOUT, LERR, OK ) | |||
| * | |||
| INFOT = 2 | |||
| CALL CUNHR_COL( 0, -1, 1, A, 1, T, 1, D, INFO ) | |||
| CALL CHKXER( 'CUNHR_COL', INFOT, NOUT, LERR, OK ) | |||
| CALL CUNHR_COL( 1, 2, 1, A, 1, T, 1, D, INFO ) | |||
| CALL CHKXER( 'CUNHR_COL', INFOT, NOUT, LERR, OK ) | |||
| * | |||
| INFOT = 3 | |||
| CALL CUNHR_COL( 0, 0, -1, A, 1, T, 1, D, INFO ) | |||
| CALL CHKXER( 'CUNHR_COL', INFOT, NOUT, LERR, OK ) | |||
| * | |||
| CALL CUNHR_COL( 0, 0, 0, A, 1, T, 1, D, INFO ) | |||
| CALL CHKXER( 'CUNHR_COL', INFOT, NOUT, LERR, OK ) | |||
| * | |||
| INFOT = 5 | |||
| CALL CUNHR_COL( 0, 0, 1, A, -1, T, 1, D, INFO ) | |||
| CALL CHKXER( 'CUNHR_COL', INFOT, NOUT, LERR, OK ) | |||
| * | |||
| CALL CUNHR_COL( 0, 0, 1, A, 0, T, 1, D, INFO ) | |||
| CALL CHKXER( 'CUNHR_COL', INFOT, NOUT, LERR, OK ) | |||
| * | |||
| CALL CUNHR_COL( 2, 0, 1, A, 1, T, 1, D, INFO ) | |||
| CALL CHKXER( 'CUNHR_COL', INFOT, NOUT, LERR, OK ) | |||
| * | |||
| INFOT = 7 | |||
| CALL CUNHR_COL( 0, 0, 1, A, 1, T, -1, D, INFO ) | |||
| CALL CHKXER( 'CUNHR_COL', INFOT, NOUT, LERR, OK ) | |||
| * | |||
| CALL CUNHR_COL( 0, 0, 1, A, 1, T, 0, D, INFO ) | |||
| CALL CHKXER( 'CUNHR_COL', INFOT, NOUT, LERR, OK ) | |||
| * | |||
| CALL CUNHR_COL( 4, 3, 2, A, 4, T, 1, D, INFO ) | |||
| CALL CHKXER( 'CUNHR_COL', INFOT, NOUT, LERR, OK ) | |||
| * | |||
| * Print a summary line. | |||
| * | |||
| CALL ALAESM( PATH, OK, NOUT ) | |||
| * | |||
| RETURN | |||
| * | |||
| * End of CERRUNHR_COL | |||
| * | |||
| END | |||
+ 2
- 2
lapack-netlib/TESTING/LIN/cerrvx.f
View File
| @@ -739,7 +739,7 @@ | |||
| $ W, 1, INFO ) | |||
| CALL CHKXER( 'CHESV_AA_2STAGE', INFOT, NOUT, LERR, OK ) | |||
| INFOT = 11 | |||
| CALL CHESV_AA_2STAGE( 'U', 2, 1, A, 2, A, 2, IP, IP, B, 1, | |||
| CALL CHESV_AA_2STAGE( 'U', 2, 1, A, 2, A, 8, IP, IP, B, 1, | |||
| $ W, 1, INFO ) | |||
| CALL CHKXER( 'CHESV_AA_2STAGE', INFOT, NOUT, LERR, OK ) | |||
| INFOT = 7 | |||
| @@ -769,7 +769,7 @@ | |||
| $ W, 1, INFO ) | |||
| CALL CHKXER( 'CSYSV_AA_2STAGE', INFOT, NOUT, LERR, OK ) | |||
| INFOT = 11 | |||
| CALL CSYSV_AA_2STAGE( 'U', 2, 1, A, 2, A, 2, IP, IP, B, 1, | |||
| CALL CSYSV_AA_2STAGE( 'U', 2, 1, A, 2, A, 8, IP, IP, B, 1, | |||
| $ W, 1, INFO ) | |||
| CALL CHKXER( 'CSYSV_AA_2STAGE', INFOT, NOUT, LERR, OK ) | |||
| INFOT = 7 | |||
+ 1
- 1
lapack-netlib/TESTING/LIN/clahilb.f
View File
| @@ -164,7 +164,7 @@ | |||
| INTEGER NMAX_EXACT, NMAX_APPROX, SIZE_D | |||
| PARAMETER (NMAX_EXACT = 6, NMAX_APPROX = 11, SIZE_D = 8) | |||
| * | |||
| * d's are generated from random permuation of those eight elements. | |||
| * d's are generated from random permutation of those eight elements. | |||
| COMPLEX D1(8), D2(8), INVD1(8), INVD2(8) | |||
| DATA D1 /(-1,0),(0,1),(-1,-1),(0,-1),(1,0),(-1,1),(1,1),(1,-1)/ | |||
| DATA D2 /(-1,0),(0,-1),(-1,1),(0,1),(1,0),(-1,-1),(1,-1),(1,1)/ | |||
+ 13
- 13
lapack-netlib/TESTING/LIN/ctsqr01.f
View File
| @@ -114,7 +114,7 @@ | |||
| * .. | |||
| * .. Local Arrays .. | |||
| INTEGER ISEED( 4 ) | |||
| COMPLEX TQUERY( 5 ), WORKQUERY | |||
| COMPLEX TQUERY( 5 ), WORKQUERY( 1 ) | |||
| * .. | |||
| * .. External Functions .. | |||
| REAL SLAMCH, CLANGE, CLANSY | |||
| @@ -173,22 +173,22 @@ | |||
| * | |||
| CALL CGEQR( M, N, AF, M, TQUERY, -1, WORKQUERY, -1, INFO ) | |||
| TSIZE = INT( TQUERY( 1 ) ) | |||
| LWORK = INT( WORKQUERY ) | |||
| LWORK = INT( WORKQUERY( 1 ) ) | |||
| CALL CGEMQR( 'L', 'N', M, M, K, AF, M, TQUERY, TSIZE, CF, M, | |||
| $ WORKQUERY, -1, INFO) | |||
| LWORK = MAX( LWORK, INT( WORKQUERY ) ) | |||
| LWORK = MAX( LWORK, INT( WORKQUERY( 1 ) ) ) | |||
| CALL CGEMQR( 'L', 'N', M, N, K, AF, M, TQUERY, TSIZE, CF, M, | |||
| $ WORKQUERY, -1, INFO) | |||
| LWORK = MAX( LWORK, INT( WORKQUERY ) ) | |||
| LWORK = MAX( LWORK, INT( WORKQUERY( 1 ) ) ) | |||
| CALL CGEMQR( 'L', 'C', M, N, K, AF, M, TQUERY, TSIZE, CF, M, | |||
| $ WORKQUERY, -1, INFO) | |||
| LWORK = MAX( LWORK, INT( WORKQUERY ) ) | |||
| LWORK = MAX( LWORK, INT( WORKQUERY( 1 ) ) ) | |||
| CALL CGEMQR( 'R', 'N', N, M, K, AF, M, TQUERY, TSIZE, DF, N, | |||
| $ WORKQUERY, -1, INFO) | |||
| LWORK = MAX( LWORK, INT( WORKQUERY ) ) | |||
| LWORK = MAX( LWORK, INT( WORKQUERY( 1 ) ) ) | |||
| CALL CGEMQR( 'R', 'C', N, M, K, AF, M, TQUERY, TSIZE, DF, N, | |||
| $ WORKQUERY, -1, INFO) | |||
| LWORK = MAX( LWORK, INT( WORKQUERY ) ) | |||
| LWORK = MAX( LWORK, INT( WORKQUERY( 1 ) ) ) | |||
| ALLOCATE ( T( TSIZE ) ) | |||
| ALLOCATE ( WORK( LWORK ) ) | |||
| srnamt = 'CGEQR' | |||
| @@ -316,22 +316,22 @@ | |||
| ELSE | |||
| CALL CGELQ( M, N, AF, M, TQUERY, -1, WORKQUERY, -1, INFO ) | |||
| TSIZE = INT( TQUERY( 1 ) ) | |||
| LWORK = INT( WORKQUERY ) | |||
| LWORK = INT( WORKQUERY( 1 ) ) | |||
| CALL CGEMLQ( 'R', 'N', N, N, K, AF, M, TQUERY, TSIZE, Q, N, | |||
| $ WORKQUERY, -1, INFO ) | |||
| LWORK = MAX( LWORK, INT( WORKQUERY ) ) | |||
| LWORK = MAX( LWORK, INT( WORKQUERY( 1 ) ) ) | |||
| CALL CGEMLQ( 'L', 'N', N, M, K, AF, M, TQUERY, TSIZE, DF, N, | |||
| $ WORKQUERY, -1, INFO) | |||
| LWORK = MAX( LWORK, INT( WORKQUERY ) ) | |||
| LWORK = MAX( LWORK, INT( WORKQUERY( 1 ) ) ) | |||
| CALL CGEMLQ( 'L', 'C', N, M, K, AF, M, TQUERY, TSIZE, DF, N, | |||
| $ WORKQUERY, -1, INFO) | |||
| LWORK = MAX( LWORK, INT( WORKQUERY ) ) | |||
| LWORK = MAX( LWORK, INT( WORKQUERY( 1 ) ) ) | |||
| CALL CGEMLQ( 'R', 'N', M, N, K, AF, M, TQUERY, TSIZE, CF, M, | |||
| $ WORKQUERY, -1, INFO) | |||
| LWORK = MAX( LWORK, INT( WORKQUERY ) ) | |||
| LWORK = MAX( LWORK, INT( WORKQUERY( 1 ) ) ) | |||
| CALL CGEMLQ( 'R', 'C', M, N, K, AF, M, TQUERY, TSIZE, CF, M, | |||
| $ WORKQUERY, -1, INFO) | |||
| LWORK = MAX( LWORK, INT( WORKQUERY ) ) | |||
| LWORK = MAX( LWORK, INT( WORKQUERY( 1 ) ) ) | |||
| ALLOCATE ( T( TSIZE ) ) | |||
| ALLOCATE ( WORK( LWORK ) ) | |||
| srnamt = 'CGELQ' | |||
+ 390
- 0
lapack-netlib/TESTING/LIN/cunhr_col01.f
View File
| @@ -0,0 +1,390 @@ | |||
| *> \brief \b CUNHR_COL01 | |||
| * | |||
| * =========== DOCUMENTATION =========== | |||
| * | |||
| * Online html documentation available at | |||
| * http://www.netlib.org/lapack/explore-html/ | |||
| * | |||
| * Definition: | |||
| * =========== | |||
| * | |||
| * SUBROUTINE CUNHR_COL01( M, N, MB1, NB1, NB2, RESULT ) | |||
| * | |||
| * .. Scalar Arguments .. | |||
| * INTEGER M, N, MB1, NB1, NB2 | |||
| * .. Return values .. | |||
| * REAL RESULT(6) | |||
| * | |||
| * | |||
| *> \par Purpose: | |||
| * ============= | |||
| *> | |||
| *> \verbatim | |||
| *> | |||
| *> CUNHR_COL01 tests CUNHR_COL using CLATSQR, CGEMQRT and CUNGTSQR. | |||
| *> Therefore, CLATSQR (part of CGEQR), CGEMQRT (part CGEMQR), CUNGTSQR | |||
| *> have to be tested before this test. | |||
| *> | |||
| *> \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] MB1 | |||
| *> \verbatim | |||
| *> MB1 is INTEGER | |||
| *> Number of row in row block in an input test matrix. | |||
| *> \endverbatim | |||
| *> | |||
| *> \param[in] NB1 | |||
| *> \verbatim | |||
| *> NB1 is INTEGER | |||
| *> Number of columns in column block an input test matrix. | |||
| *> \endverbatim | |||
| *> | |||
| *> \param[in] NB2 | |||
| *> \verbatim | |||
| *> NB2 is INTEGER | |||
| *> Number of columns in column block in an output test matrix. | |||
| *> \endverbatim | |||
| *> | |||
| *> \param[out] RESULT | |||
| *> \verbatim | |||
| *> RESULT is REAL array, dimension (6) | |||
| *> Results of each of the six tests below. | |||
| *> ( C is a M-by-N random matrix, D is a N-by-M random matrix ) | |||
| *> | |||
| *> RESULT(1) = | A - Q * R | / (eps * m * |A|) | |||
| *> RESULT(2) = | I - (Q**H) * Q | / (eps * m ) | |||
| *> RESULT(3) = | Q * C - Q * C | / (eps * m * |C|) | |||
| *> RESULT(4) = | (Q**H) * C - (Q**H) * C | / (eps * m * |C|) | |||
| *> RESULT(5) = | (D * Q) - D * Q | / (eps * m * |D|) | |||
| *> RESULT(6) = | D * (Q**H) - D * (Q**H) | / (eps * m * |D|) | |||
| *> \endverbatim | |||
| * | |||
| * Authors: | |||
| * ======== | |||
| * | |||
| *> \author Univ. of Tennessee | |||
| *> \author Univ. of California Berkeley | |||
| *> \author Univ. of Colorado Denver | |||
| *> \author NAG Ltd. | |||
| * | |||
| *> \date November 2019 | |||
| * | |||
| *> \ingroup complex16_lin | |||
| * | |||
| * ===================================================================== | |||
| SUBROUTINE CUNHR_COL01( M, N, MB1, NB1, NB2, RESULT ) | |||
| IMPLICIT NONE | |||
| * | |||
| * -- LAPACK test routine (version 3.9.0) -- | |||
| * -- LAPACK is a software package provided by Univ. of Tennessee, -- | |||
| * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- | |||
| * November 2019 | |||
| * | |||
| * .. Scalar Arguments .. | |||
| INTEGER M, N, MB1, NB1, NB2 | |||
| * .. Return values .. | |||
| REAL RESULT(6) | |||
| * | |||
| * ===================================================================== | |||
| * | |||
| * .. | |||
| * .. Local allocatable arrays | |||
| COMPLEX, ALLOCATABLE :: A(:,:), AF(:,:), Q(:,:), R(:,:), | |||
| $ WORK( : ), T1(:,:), T2(:,:), DIAG(:), | |||
| $ C(:,:), CF(:,:), D(:,:), DF(:,:) | |||
| REAL, ALLOCATABLE :: RWORK(:) | |||
| * | |||
| * .. Parameters .. | |||
| REAL ZERO | |||
| PARAMETER ( ZERO = 0.0E+0 ) | |||
| COMPLEX CONE, CZERO | |||
| PARAMETER ( CONE = ( 1.0E+0, 0.0E+0 ), | |||
| $ CZERO = ( 0.0E+0, 0.0E+0 ) ) | |||
| * .. | |||
| * .. Local Scalars .. | |||
| LOGICAL TESTZEROS | |||
| INTEGER INFO, I, J, K, L, LWORK, NB1_UB, NB2_UB, NRB | |||
| REAL ANORM, EPS, RESID, CNORM, DNORM | |||
| * .. | |||
| * .. Local Arrays .. | |||
| INTEGER ISEED( 4 ) | |||
| COMPLEX WORKQUERY( 1 ) | |||
| * .. | |||
| * .. External Functions .. | |||
| REAL SLAMCH, CLANGE, CLANSY | |||
| EXTERNAL SLAMCH, CLANGE, CLANSY | |||
| * .. | |||
| * .. External Subroutines .. | |||
| EXTERNAL CLACPY, CLARNV, CLASET, CLATSQR, CUNHR_COL, | |||
| $ CUNGTSQR, CSCAL, CGEMM, CGEMQRT, CHERK | |||
| * .. | |||
| * .. Intrinsic Functions .. | |||
| INTRINSIC CEILING, REAL, MAX, MIN | |||
| * .. | |||
| * .. Scalars in Common .. | |||
| CHARACTER(LEN=32) SRNAMT | |||
| * .. | |||
| * .. Common blocks .. | |||
| COMMON / SRMNAMC / SRNAMT | |||
| * .. | |||
| * .. Data statements .. | |||
| DATA ISEED / 1988, 1989, 1990, 1991 / | |||
| * | |||
| * TEST MATRICES WITH HALF OF MATRIX BEING ZEROS | |||
| * | |||
| TESTZEROS = .FALSE. | |||
| * | |||
| EPS = SLAMCH( 'Epsilon' ) | |||
| K = MIN( M, N ) | |||
| L = MAX( M, N, 1) | |||
| * | |||
| * Dynamically allocate local arrays | |||
| * | |||
| ALLOCATE ( A(M,N), AF(M,N), Q(L,L), R(M,L), RWORK(L), | |||
| $ C(M,N), CF(M,N), | |||
| $ D(N,M), DF(N,M) ) | |||
| * | |||
| * 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 ) | |||
| * | |||
| * Number of row blocks in CLATSQR | |||
| * | |||
| NRB = MAX( 1, CEILING( REAL( M - N ) / REAL( MB1 - N ) ) ) | |||
| * | |||
| ALLOCATE ( T1( NB1, N * NRB ) ) | |||
| ALLOCATE ( T2( NB2, N ) ) | |||
| ALLOCATE ( DIAG( N ) ) | |||
| * | |||
| * Begin determine LWORK for the array WORK and allocate memory. | |||
| * | |||
| * CLATSQR requires NB1 to be bounded by N. | |||
| * | |||
| NB1_UB = MIN( NB1, N) | |||
| * | |||
| * CGEMQRT requires NB2 to be bounded by N. | |||
| * | |||
| NB2_UB = MIN( NB2, N) | |||
| * | |||
| CALL CLATSQR( M, N, MB1, NB1_UB, AF, M, T1, NB1, | |||
| $ WORKQUERY, -1, INFO ) | |||
| LWORK = INT( WORKQUERY( 1 ) ) | |||
| CALL CUNGTSQR( M, N, MB1, NB1, AF, M, T1, NB1, WORKQUERY, -1, | |||
| $ INFO ) | |||
| LWORK = MAX( LWORK, INT( WORKQUERY( 1 ) ) ) | |||
| * | |||
| * In CGEMQRT, WORK is N*NB2_UB if SIDE = 'L', | |||
| * or M*NB2_UB if SIDE = 'R'. | |||
| * | |||
| LWORK = MAX( LWORK, NB2_UB * N, NB2_UB * M ) | |||
| * | |||
| ALLOCATE ( WORK( LWORK ) ) | |||
| * | |||
| * End allocate memory for WORK. | |||
| * | |||
| * | |||
| * Begin Householder reconstruction routines | |||
| * | |||
| * Factor the matrix A in the array AF. | |||
| * | |||
| SRNAMT = 'CLATSQR' | |||
| CALL CLATSQR( M, N, MB1, NB1_UB, AF, M, T1, NB1, WORK, LWORK, | |||
| $ INFO ) | |||
| * | |||
| * Copy the factor R into the array R. | |||
| * | |||
| SRNAMT = 'CLACPY' | |||
| CALL CLACPY( 'U', M, N, AF, M, R, M ) | |||
| * | |||
| * Reconstruct the orthogonal matrix Q. | |||
| * | |||
| SRNAMT = 'CUNGTSQR' | |||
| CALL CUNGTSQR( M, N, MB1, NB1, AF, M, T1, NB1, WORK, LWORK, | |||
| $ INFO ) | |||
| * | |||
| * Perform the Householder reconstruction, the result is stored | |||
| * the arrays AF and T2. | |||
| * | |||
| SRNAMT = 'CUNHR_COL' | |||
| CALL CUNHR_COL( M, N, NB2, AF, M, T2, NB2, DIAG, INFO ) | |||
| * | |||
| * Compute the factor R_hr corresponding to the Householder | |||
| * reconstructed Q_hr and place it in the upper triangle of AF to | |||
| * match the Q storage format in CGEQRT. R_hr = R_tsqr * S, | |||
| * this means changing the sign of I-th row of the matrix R_tsqr | |||
| * according to sign of of I-th diagonal element DIAG(I) of the | |||
| * matrix S. | |||
| * | |||
| SRNAMT = 'CLACPY' | |||
| CALL CLACPY( 'U', M, N, R, M, AF, M ) | |||
| * | |||
| DO I = 1, N | |||
| IF( DIAG( I ).EQ.-CONE ) THEN | |||
| CALL CSCAL( N+1-I, -CONE, AF( I, I ), M ) | |||
| END IF | |||
| END DO | |||
| * | |||
| * End Householder reconstruction routines. | |||
| * | |||
| * | |||
| * Generate the m-by-m matrix Q | |||
| * | |||
| CALL CLASET( 'Full', M, M, CZERO, CONE, Q, M ) | |||
| * | |||
| SRNAMT = 'CGEMQRT' | |||
| CALL CGEMQRT( 'L', 'N', M, M, K, NB2_UB, AF, M, T2, NB2, Q, M, | |||
| $ WORK, INFO ) | |||
| * | |||
| * Copy R | |||
| * | |||
| CALL CLASET( 'Full', M, N, CZERO, CZERO, R, M ) | |||
| * | |||
| CALL CLACPY( 'Upper', M, N, AF, M, R, M ) | |||
| * | |||
| * TEST 1 | |||
| * Compute |R - (Q**H)*A| / ( eps * m * |A| ) and store in RESULT(1) | |||
| * | |||
| CALL CGEMM( 'C', 'N', M, N, M, -CONE, Q, M, A, M, CONE, 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 | |||
| * | |||
| * TEST 2 | |||
| * Compute |I - (Q**H)*Q| / ( eps * m ) and store in RESULT(2) | |||
| * | |||
| CALL CLASET( 'Full', M, M, CZERO, CONE, R, M ) | |||
| CALL CHERK( 'U', 'C', M, M, -CONE, Q, M, CONE, R, M ) | |||
| RESID = CLANSY( '1', 'Upper', M, R, M, RWORK ) | |||
| RESULT( 2 ) = RESID / ( EPS * MAX( 1, M ) ) | |||
| * | |||
| * Generate random m-by-n matrix C | |||
| * | |||
| 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 = CF | |||
| * | |||
| SRNAMT = 'CGEMQRT' | |||
| CALL CGEMQRT( 'L', 'N', M, N, K, NB2_UB, AF, M, T2, NB2, CF, M, | |||
| $ WORK, INFO ) | |||
| * | |||
| * TEST 3 | |||
| * Compute |CF - Q*C| / ( eps * m * |C| ) | |||
| * | |||
| CALL CGEMM( 'N', 'N', M, N, M, -CONE, Q, M, C, M, CONE, 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 (Q**H)*C = CF | |||
| * | |||
| SRNAMT = 'CGEMQRT' | |||
| CALL CGEMQRT( 'L', 'C', M, N, K, NB2_UB, AF, M, T2, NB2, CF, M, | |||
| $ WORK, INFO ) | |||
| * | |||
| * TEST 4 | |||
| * Compute |CF - (Q**H)*C| / ( eps * m * |C|) | |||
| * | |||
| CALL CGEMM( 'C', 'N', M, N, M, -CONE, Q, M, C, M, CONE, 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 = DF | |||
| * | |||
| SRNAMT = 'CGEMQRT' | |||
| CALL CGEMQRT( 'R', 'N', N, M, K, NB2_UB, AF, M, T2, NB2, DF, N, | |||
| $ WORK, INFO ) | |||
| * | |||
| * TEST 5 | |||
| * Compute |DF - D*Q| / ( eps * m * |D| ) | |||
| * | |||
| CALL CGEMM( 'N', 'N', N, M, M, -CONE, D, N, Q, M, CONE, 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 = DF | |||
| * | |||
| SRNAMT = 'CGEMQRT' | |||
| CALL CGEMQRT( 'R', 'C', N, M, K, NB2_UB, AF, M, T2, NB2, DF, N, | |||
| $ WORK, INFO ) | |||
| * | |||
| * TEST 6 | |||
| * Compute |DF - D*(Q**H)| / ( eps * m * |D| ) | |||
| * | |||
| CALL CGEMM( 'N', 'C', N, M, M, -CONE, D, N, Q, M, CONE, DF, N ) | |||
| RESID = CLANGE( '1', N, M, DF, N, RWORK ) | |||
| IF( DNORM.GT.ZERO ) THEN | |||
| RESULT( 6 ) = RESID / ( EPS * MAX( 1, M ) * DNORM ) | |||
| ELSE | |||
| RESULT( 6 ) = ZERO | |||
| END IF | |||
| * | |||
| * Deallocate all arrays | |||
| * | |||
| DEALLOCATE ( A, AF, Q, R, RWORK, WORK, T1, T2, DIAG, | |||
| $ C, D, CF, DF ) | |||
| * | |||
| RETURN | |||
| * | |||
| * End of CUNHR_COL01 | |||
| * | |||
| END | |||
+ 27
- 12
lapack-netlib/TESTING/LIN/dchkaa.f
View File
| @@ -68,6 +68,10 @@ | |||
| *> DEQ | |||
| *> DQT | |||
| *> DQX | |||
| *> DTQ | |||
| *> DXQ | |||
| *> DTS | |||
| *> DHH | |||
| *> \endverbatim | |||
| * | |||
| * Parameters: | |||
| @@ -102,17 +106,17 @@ | |||
| *> \author Univ. of Colorado Denver | |||
| *> \author NAG Ltd. | |||
| * | |||
| *> \date April 2012 | |||
| *> \date November 2019 | |||
| * | |||
| *> \ingroup double_lin | |||
| * | |||
| * ===================================================================== | |||
| PROGRAM DCHKAA | |||
| * | |||
| * -- LAPACK test routine (version 3.8.0) -- | |||
| * -- LAPACK test routine (version 3.9.0) -- | |||
| * -- LAPACK is a software package provided by Univ. of Tennessee, -- | |||
| * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- | |||
| * April 2012 | |||
| * Novemebr 2019 | |||
| * | |||
| * ===================================================================== | |||
| * | |||
| @@ -159,15 +163,14 @@ | |||
| * .. | |||
| * .. External Subroutines .. | |||
| EXTERNAL ALAREQ, DCHKEQ, DCHKGB, DCHKGE, DCHKGT, DCHKLQ, | |||
| $ DCHKPB, DCHKPO, DCHKPS, DCHKPP, DCHKPT, DCHKQ3, | |||
| $ DCHKQL, DCHKQR, DCHKRQ, DCHKSP, DCHKSY, | |||
| $ DCHKSY_ROOK, DCHKSY_RK, DCHKSY_AA, DCHKTB, | |||
| $ DCHKTP, DCHKTR, DCHKTZ, DDRVGB, DDRVGE, | |||
| $ DDRVGT, DDRVLS, DDRVPB, DDRVPO, DDRVPP, | |||
| $ DDRVPT, DDRVSP, DDRVSY, DDRVSY_ROOK, DDRVSY_RK, | |||
| $ DDRVSY_AA, ILAVER, DCHKQRT, | |||
| $ DCHKQRTP, DCHKLQTP, DCHKTSQR, DCHKLQT | |||
| $ DCHKORHR_COL, DCHKPB, DCHKPO, DCHKPS, DCHKPP, | |||
| $ DCHKPT, DCHKQ3, DCHKQL, DCHKQR, DCHKRQ, DCHKSP, | |||
| $ DCHKSY, DCHKSY_ROOK, DCHKSY_RK, DCHKSY_AA, | |||
| $ DCHKTB, DCHKTP, DCHKTR, DCHKTZ, DDRVGB, DDRVGE, | |||
| $ DDRVGT, DDRVLS, DDRVPB, DDRVPO, DDRVPP, DDRVPT, | |||
| $ DDRVSP, DDRVSY, DDRVSY_ROOK, DDRVSY_RK, | |||
| $ DDRVSY_AA, ILAVER, DCHKLQTP, DCHKQRT, DCHKQRTP, | |||
| $ DCHKLQT,DCHKTSQR | |||
| * .. | |||
| * .. Scalars in Common .. | |||
| LOGICAL LERR, OK | |||
| @@ -1007,8 +1010,20 @@ | |||
| ELSE | |||
| WRITE( NOUT, FMT = 9989 )PATH | |||
| END IF | |||
| * | |||
| ELSE IF( LSAMEN( 2, C2, 'HH' ) ) THEN | |||
| * | |||
| * HH: Householder reconstruction for tall-skinny matrices | |||
| * | |||
| IF( TSTCHK ) THEN | |||
| CALL DCHKORHR_COL( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, | |||
| $ NBVAL, NOUT ) | |||
| ELSE | |||
| WRITE( NOUT, FMT = 9989 ) PATH | |||
| END IF | |||
| * | |||
| ELSE | |||
| * | |||
| WRITE( NOUT, FMT = 9990 )PATH | |||
| END IF | |||
+ 239
- 0
lapack-netlib/TESTING/LIN/dchkorhr_col.f
View File
| @@ -0,0 +1,239 @@ | |||
| *> \brief \b DCHKORHR_COL | |||
| * | |||
| * =========== DOCUMENTATION =========== | |||
| * | |||
| * Online html documentation available at | |||
| * http://www.netlib.org/lapack/explore-html/ | |||
| * | |||
| * Definition: | |||
| * =========== | |||
| * | |||
| * SUBROUTINE DCHKORHR_COL( 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 | |||
| *> | |||
| *> DCHKORHR_COL tests DORHR_COL using DLATSQR and DGEMQRT. Therefore, DLATSQR | |||
| *> (used in DGEQR) and DGEMQRT (used in DGEMQR) have to be tested | |||
| *> before this test. | |||
| *> | |||
| *> \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 2019 | |||
| * | |||
| *> \ingroup double_lin | |||
| * | |||
| * ===================================================================== | |||
| SUBROUTINE DCHKORHR_COL( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, | |||
| $ NBVAL, NOUT ) | |||
| IMPLICIT NONE | |||
| * | |||
| * -- LAPACK test routine (version 3.7.0) -- | |||
| * -- LAPACK is a software package provided by Univ. of Tennessee, -- | |||
| * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- | |||
| * December 2016 | |||
| * | |||
| * .. 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(LEN=3) PATH | |||
| INTEGER I, IMB1, INB1, INB2, J, T, M, N, MB1, NB1, | |||
| $ NB2, NFAIL, NERRS, NRUN | |||
| * | |||
| * .. Local Arrays .. | |||
| DOUBLE PRECISION RESULT( NTESTS ) | |||
| * .. | |||
| * .. External Subroutines .. | |||
| EXTERNAL ALAHD, ALASUM, DERRORHR_COL, DORHR_COL01 | |||
| * .. | |||
| * .. Intrinsic Functions .. | |||
| INTRINSIC MAX, MIN | |||
| * .. | |||
| * .. Scalars in Common .. | |||
| LOGICAL LERR, OK | |||
| CHARACTER(LEN=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 ) = 'HH' | |||
| NRUN = 0 | |||
| NFAIL = 0 | |||
| NERRS = 0 | |||
| * | |||
| * Test the error exits | |||
| * | |||
| IF( TSTERR ) CALL DERRORHR_COL( 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 ) | |||
| * | |||
| * Only for M >= N | |||
| * | |||
| IF ( MIN( M, N ).GT.0 .AND. M.GE.N ) THEN | |||
| * | |||
| * Do for each possible value of MB1 | |||
| * | |||
| DO IMB1 = 1, NNB | |||
| MB1 = NBVAL( IMB1 ) | |||
| * | |||
| * Only for MB1 > N | |||
| * | |||
| IF ( MB1.GT.N ) THEN | |||
| * | |||
| * Do for each possible value of NB1 | |||
| * | |||
| DO INB1 = 1, NNB | |||
| NB1 = NBVAL( INB1 ) | |||
| * | |||
| * Do for each possible value of NB2 | |||
| * | |||
| DO INB2 = 1, NNB | |||
| NB2 = NBVAL( INB2 ) | |||
| * | |||
| IF( NB1.GT.0 .AND. NB2.GT.0 ) THEN | |||
| * | |||
| * Test DORHR_COL | |||
| * | |||
| CALL DORHR_COL01( M, N, MB1, NB1, NB2, | |||
| $ 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, MB1, | |||
| $ NB1, NB2, T, RESULT( T ) | |||
| NFAIL = NFAIL + 1 | |||
| END IF | |||
| END DO | |||
| NRUN = NRUN + NTESTS | |||
| END IF | |||
| END DO | |||
| END DO | |||
| END IF | |||
| END DO | |||
| END IF | |||
| END DO | |||
| END DO | |||
| * | |||
| * Print a summary of the results. | |||
| * | |||
| CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) | |||
| * | |||
| 9999 FORMAT( 'M=', I5, ', N=', I5, ', MB1=', I5, | |||
| $ ', NB1=', I5, ', NB2=', I5,' test(', I2, ')=', G12.5 ) | |||
| RETURN | |||
| * | |||
| * End of DCHKORHR_COL | |||
| * | |||
| END | |||
+ 8
- 8
lapack-netlib/TESTING/LIN/ddrvls.f
View File
| @@ -233,8 +233,8 @@ | |||
| DOUBLE PRECISION EPS, NORMA, NORMB, RCOND | |||
| * .. | |||
| * .. Local Arrays .. | |||
| INTEGER ISEED( 4 ), ISEEDY( 4 ), IWQ | |||
| DOUBLE PRECISION RESULT( NTESTS ), WQ | |||
| INTEGER ISEED( 4 ), ISEEDY( 4 ), IWQ( 1 ) | |||
| DOUBLE PRECISION RESULT( NTESTS ), WQ( 1 ) | |||
| * .. | |||
| * .. Allocatable Arrays .. | |||
| DOUBLE PRECISION, ALLOCATABLE :: WORK (:) | |||
| @@ -359,27 +359,27 @@ | |||
| * Compute workspace needed for DGELS | |||
| CALL DGELS( TRANS, M, N, NRHS, A, LDA, | |||
| $ B, LDB, WQ, -1, INFO ) | |||
| LWORK_DGELS = INT ( WQ ) | |||
| LWORK_DGELS = INT ( WQ ( 1 ) ) | |||
| * Compute workspace needed for DGETSLS | |||
| CALL DGETSLS( TRANS, M, N, NRHS, A, LDA, | |||
| $ B, LDB, WQ, -1, INFO ) | |||
| LWORK_DGETSLS = INT( WQ ) | |||
| LWORK_DGETSLS = INT( WQ ( 1 ) ) | |||
| ENDDO | |||
| END IF | |||
| * Compute workspace needed for DGELSY | |||
| CALL DGELSY( M, N, NRHS, A, LDA, B, LDB, IWQ, | |||
| $ RCOND, CRANK, WQ, -1, INFO ) | |||
| LWORK_DGELSY = INT( WQ ) | |||
| LWORK_DGELSY = INT( WQ ( 1 ) ) | |||
| * Compute workspace needed for DGELSS | |||
| CALL DGELSS( M, N, NRHS, A, LDA, B, LDB, S, | |||
| $ RCOND, CRANK, WQ, -1 , INFO ) | |||
| LWORK_DGELSS = INT( WQ ) | |||
| LWORK_DGELSS = INT( WQ ( 1 ) ) | |||
| * Compute workspace needed for DGELSD | |||
| CALL DGELSD( M, N, NRHS, A, LDA, B, LDB, S, | |||
| $ RCOND, CRANK, WQ, -1, IWQ, INFO ) | |||
| LWORK_DGELSD = INT( WQ ) | |||
| LWORK_DGELSD = INT( WQ ( 1 ) ) | |||
| * Compute LIWORK workspace needed for DGELSY and DGELSD | |||
| LIWORK = MAX( LIWORK, N, IWQ ) | |||
| LIWORK = MAX( LIWORK, N, IWQ( 1 ) ) | |||
| * Compute LWORK workspace needed for all functions | |||
| LWORK = MAX( LWORK, LWORK_DGELS, LWORK_DGETSLS, | |||
| $ LWORK_DGELSY, LWORK_DGELSS, | |||
+ 164
- 0
lapack-netlib/TESTING/LIN/derrorhr_col.f
View File
| @@ -0,0 +1,164 @@ | |||
| *> \brief \b DERRORHR_COL | |||
| * | |||
| * =========== DOCUMENTATION =========== | |||
| * | |||
| * Online html documentation available at | |||
| * http://www.netlib.org/lapack/explore-html/ | |||
| * | |||
| * Definition: | |||
| * =========== | |||
| * | |||
| * SUBROUTINE DERRORHR_COL( PATH, NUNIT ) | |||
| * | |||
| * .. Scalar Arguments .. | |||
| * CHARACTER*3 PATH | |||
| * INTEGER NUNIT | |||
| * .. | |||
| * | |||
| * | |||
| *> \par Purpose: | |||
| * ============= | |||
| *> | |||
| *> \verbatim | |||
| *> | |||
| *> DERRORHR_COL tests the error exits for DORHR_COL that does | |||
| *> Householder reconstruction from the ouput of tall-skinny | |||
| *> factorization DLATSQR. | |||
| *> \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 2019 | |||
| * | |||
| *> \ingroup double_lin | |||
| * | |||
| * ===================================================================== | |||
| SUBROUTINE DERRORHR_COL( PATH, NUNIT ) | |||
| IMPLICIT NONE | |||
| * | |||
| * -- LAPACK test routine (version 3.9.0) -- | |||
| * -- LAPACK is a software package provided by Univ. of Tennessee, -- | |||
| * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- | |||
| * November 2019 | |||
| * | |||
| * .. Scalar Arguments .. | |||
| CHARACTER(LEN=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 ), D(NMAX) | |||
| * .. | |||
| * .. External Subroutines .. | |||
| EXTERNAL ALAESM, CHKXER, DORHR_COL | |||
| * .. | |||
| * .. Scalars in Common .. | |||
| LOGICAL LERR, OK | |||
| CHARACTER(LEN=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.D+0 / DBLE( I+J ) | |||
| T( I, J ) = 1.D+0 / DBLE( I+J ) | |||
| END DO | |||
| D( J ) = 0.D+0 | |||
| END DO | |||
| OK = .TRUE. | |||
| * | |||
| * Error exits for Householder reconstruction | |||
| * | |||
| * DORHR_COL | |||
| * | |||
| SRNAMT = 'DORHR_COL' | |||
| * | |||
| INFOT = 1 | |||
| CALL DORHR_COL( -1, 0, 1, A, 1, T, 1, D, INFO ) | |||
| CALL CHKXER( 'DORHR_COL', INFOT, NOUT, LERR, OK ) | |||
| * | |||
| INFOT = 2 | |||
| CALL DORHR_COL( 0, -1, 1, A, 1, T, 1, D, INFO ) | |||
| CALL CHKXER( 'DORHR_COL', INFOT, NOUT, LERR, OK ) | |||
| CALL DORHR_COL( 1, 2, 1, A, 1, T, 1, D, INFO ) | |||
| CALL CHKXER( 'DORHR_COL', INFOT, NOUT, LERR, OK ) | |||
| * | |||
| INFOT = 3 | |||
| CALL DORHR_COL( 0, 0, -1, A, 1, T, 1, D, INFO ) | |||
| CALL CHKXER( 'DORHR_COL', INFOT, NOUT, LERR, OK ) | |||
| * | |||
| CALL DORHR_COL( 0, 0, 0, A, 1, T, 1, D, INFO ) | |||
| CALL CHKXER( 'DORHR_COL', INFOT, NOUT, LERR, OK ) | |||
| * | |||
| INFOT = 5 | |||
| CALL DORHR_COL( 0, 0, 1, A, -1, T, 1, D, INFO ) | |||
| CALL CHKXER( 'DORHR_COL', INFOT, NOUT, LERR, OK ) | |||
| * | |||
| CALL DORHR_COL( 0, 0, 1, A, 0, T, 1, D, INFO ) | |||
| CALL CHKXER( 'DORHR_COL', INFOT, NOUT, LERR, OK ) | |||
| * | |||
| CALL DORHR_COL( 2, 0, 1, A, 1, T, 1, D, INFO ) | |||
| CALL CHKXER( 'DORHR_COL', INFOT, NOUT, LERR, OK ) | |||
| * | |||
| INFOT = 7 | |||
| CALL DORHR_COL( 0, 0, 1, A, 1, T, -1, D, INFO ) | |||
| CALL CHKXER( 'DORHR_COL', INFOT, NOUT, LERR, OK ) | |||
| * | |||
| CALL DORHR_COL( 0, 0, 1, A, 1, T, 0, D, INFO ) | |||
| CALL CHKXER( 'DORHR_COL', INFOT, NOUT, LERR, OK ) | |||
| * | |||
| CALL DORHR_COL( 4, 3, 2, A, 4, T, 1, D, INFO ) | |||
| CALL CHKXER( 'DORHR_COL', INFOT, NOUT, LERR, OK ) | |||
| * | |||
| * Print a summary line. | |||
| * | |||
| CALL ALAESM( PATH, OK, NOUT ) | |||
| * | |||
| RETURN | |||
| * | |||
| * End of DERRORHR_COL | |||
| * | |||
| END | |||
+ 1
- 1
lapack-netlib/TESTING/LIN/derrvx.f
View File
| @@ -740,7 +740,7 @@ | |||
| $ W, 1, INFO ) | |||
| CALL CHKXER( 'DSYSV_AA_2STAGE', INFOT, NOUT, LERR, OK ) | |||
| INFOT = 11 | |||
| CALL DSYSV_AA_2STAGE( 'U', 2, 1, A, 2, A, 2, IP, IP, B, 1, | |||
| CALL DSYSV_AA_2STAGE( 'U', 2, 1, A, 2, A, 8, IP, IP, B, 1, | |||
| $ W, 1, INFO ) | |||
| CALL CHKXER( 'DSYSV_AA_2STAGE', INFOT, NOUT, LERR, OK ) | |||
| INFOT = 7 | |||
+ 386
- 0
lapack-netlib/TESTING/LIN/dorhr_col01.f
View File
| @@ -0,0 +1,386 @@ | |||
| *> \brief \b DORHR_COL01 | |||
| * | |||
| * =========== DOCUMENTATION =========== | |||
| * | |||
| * Online html documentation available at | |||
| * http://www.netlib.org/lapack/explore-html/ | |||
| * | |||
| * Definition: | |||
| * =========== | |||
| * | |||
| * SUBROUTINE DORHR_COL01( M, N, MB1, NB1, NB2, RESULT ) | |||
| * | |||
| * .. Scalar Arguments .. | |||
| * INTEGER M, N, MB1, NB1, NB2 | |||
| * .. Return values .. | |||
| * DOUBLE PRECISION RESULT(6) | |||
| * | |||
| * | |||
| *> \par Purpose: | |||
| * ============= | |||
| *> | |||
| *> \verbatim | |||
| *> | |||
| *> DORHR_COL01 tests DORHR_COL using DLATSQR, DGEMQRT and DORGTSQR. | |||
| *> Therefore, DLATSQR (part of DGEQR), DGEMQRT (part DGEMQR), DORGTSQR | |||
| *> have to be tested before this test. | |||
| *> | |||
| *> \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] MB1 | |||
| *> \verbatim | |||
| *> MB1 is INTEGER | |||
| *> Number of row in row block in an input test matrix. | |||
| *> \endverbatim | |||
| *> | |||
| *> \param[in] NB1 | |||
| *> \verbatim | |||
| *> NB1 is INTEGER | |||
| *> Number of columns in column block an input test matrix. | |||
| *> \endverbatim | |||
| *> | |||
| *> \param[in] NB2 | |||
| *> \verbatim | |||
| *> NB2 is INTEGER | |||
| *> Number of columns in column block in an output test matrix. | |||
| *> \endverbatim | |||
| *> | |||
| *> \param[out] RESULT | |||
| *> \verbatim | |||
| *> RESULT is DOUBLE PRECISION array, dimension (6) | |||
| *> Results of each of the six tests below. | |||
| *> ( C is a M-by-N random matrix, D is a N-by-M random matrix ) | |||
| *> | |||
| *> RESULT(1) = | A - Q * R | / (eps * m * |A|) | |||
| *> RESULT(2) = | I - (Q**H) * Q | / (eps * m ) | |||
| *> RESULT(3) = | Q * C - Q * C | / (eps * m * |C|) | |||
| *> RESULT(4) = | (Q**H) * C - (Q**H) * C | / (eps * m * |C|) | |||
| *> RESULT(5) = | (D * Q) - D * Q | / (eps * m * |D|) | |||
| *> RESULT(6) = | D * (Q**H) - D * (Q**H) | / (eps * m * |D|) | |||
| *> \endverbatim | |||
| * | |||
| * Authors: | |||
| * ======== | |||
| * | |||
| *> \author Univ. of Tennessee | |||
| *> \author Univ. of California Berkeley | |||
| *> \author Univ. of Colorado Denver | |||
| *> \author NAG Ltd. | |||
| * | |||
| *> \date November 2019 | |||
| * | |||
| *> \ingroup single_lin | |||
| * | |||
| * ===================================================================== | |||
| SUBROUTINE DORHR_COL01( M, N, MB1, NB1, NB2, RESULT ) | |||
| IMPLICIT NONE | |||
| * | |||
| * -- LAPACK test routine (version 3.9.0) -- | |||
| * -- LAPACK is a software package provided by Univ. of Tennessee, -- | |||
| * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- | |||
| * November 2019 | |||
| * | |||
| * .. Scalar Arguments .. | |||
| INTEGER M, N, MB1, NB1, NB2 | |||
| * .. Return values .. | |||
| DOUBLE PRECISION RESULT(6) | |||
| * | |||
| * ===================================================================== | |||
| * | |||
| * .. | |||
| * .. Local allocatable arrays | |||
| DOUBLE PRECISION, ALLOCATABLE :: A(:,:), AF(:,:), Q(:,:), R(:,:), | |||
| $ RWORK(:), WORK( : ), T1(:,:), T2(:,:), DIAG(:), | |||
| $ C(:,:), CF(:,:), D(:,:), DF(:,:) | |||
| * | |||
| * .. Parameters .. | |||
| DOUBLE PRECISION ONE, ZERO | |||
| PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) | |||
| * .. | |||
| * .. Local Scalars .. | |||
| LOGICAL TESTZEROS | |||
| INTEGER INFO, I, J, K, L, LWORK, NB1_UB, NB2_UB, NRB | |||
| DOUBLE PRECISION ANORM, EPS, RESID, CNORM, DNORM | |||
| * .. | |||
| * .. Local Arrays .. | |||
| INTEGER ISEED( 4 ) | |||
| DOUBLE PRECISION WORKQUERY( 1 ) | |||
| * .. | |||
| * .. External Functions .. | |||
| DOUBLE PRECISION DLAMCH, DLANGE, DLANSY | |||
| EXTERNAL DLAMCH, DLANGE, DLANSY | |||
| * .. | |||
| * .. External Subroutines .. | |||
| EXTERNAL DLACPY, DLARNV, DLASET, DLATSQR, DORHR_COL, | |||
| $ DORGTSQR, DSCAL, DGEMM, DGEMQRT, DSYRK | |||
| * .. | |||
| * .. Intrinsic Functions .. | |||
| INTRINSIC CEILING, DBLE, MAX, MIN | |||
| * .. | |||
| * .. Scalars in Common .. | |||
| CHARACTER(LEN=32) SRNAMT | |||
| * .. | |||
| * .. Common blocks .. | |||
| COMMON / SRMNAMC / SRNAMT | |||
| * .. | |||
| * .. Data statements .. | |||
| DATA ISEED / 1988, 1989, 1990, 1991 / | |||
| * | |||
| * TEST MATRICES WITH HALF OF MATRIX BEING ZEROS | |||
| * | |||
| TESTZEROS = .FALSE. | |||
| * | |||
| EPS = DLAMCH( 'Epsilon' ) | |||
| K = MIN( M, N ) | |||
| L = MAX( M, N, 1) | |||
| * | |||
| * Dynamically allocate local arrays | |||
| * | |||
| ALLOCATE ( A(M,N), AF(M,N), Q(L,L), R(M,L), RWORK(L), | |||
| $ C(M,N), CF(M,N), | |||
| $ D(N,M), DF(N,M) ) | |||
| * | |||
| * 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 ) | |||
| * | |||
| * Number of row blocks in DLATSQR | |||
| * | |||
| NRB = MAX( 1, CEILING( DBLE( M - N ) / DBLE( MB1 - N ) ) ) | |||
| * | |||
| ALLOCATE ( T1( NB1, N * NRB ) ) | |||
| ALLOCATE ( T2( NB2, N ) ) | |||
| ALLOCATE ( DIAG( N ) ) | |||
| * | |||
| * Begin determine LWORK for the array WORK and allocate memory. | |||
| * | |||
| * DLATSQR requires NB1 to be bounded by N. | |||
| * | |||
| NB1_UB = MIN( NB1, N) | |||
| * | |||
| * DGEMQRT requires NB2 to be bounded by N. | |||
| * | |||
| NB2_UB = MIN( NB2, N) | |||
| * | |||
| CALL DLATSQR( M, N, MB1, NB1_UB, AF, M, T1, NB1, | |||
| $ WORKQUERY, -1, INFO ) | |||
| LWORK = INT( WORKQUERY( 1 ) ) | |||
| CALL DORGTSQR( M, N, MB1, NB1, AF, M, T1, NB1, WORKQUERY, -1, | |||
| $ INFO ) | |||
| LWORK = MAX( LWORK, INT( WORKQUERY( 1 ) ) ) | |||
| * | |||
| * In DGEMQRT, WORK is N*NB2_UB if SIDE = 'L', | |||
| * or M*NB2_UB if SIDE = 'R'. | |||
| * | |||
| LWORK = MAX( LWORK, NB2_UB * N, NB2_UB * M ) | |||
| * | |||
| ALLOCATE ( WORK( LWORK ) ) | |||
| * | |||
| * End allocate memory for WORK. | |||
| * | |||
| * | |||
| * Begin Householder reconstruction routines | |||
| * | |||
| * Factor the matrix A in the array AF. | |||
| * | |||
| SRNAMT = 'DLATSQR' | |||
| CALL DLATSQR( M, N, MB1, NB1_UB, AF, M, T1, NB1, WORK, LWORK, | |||
| $ INFO ) | |||
| * | |||
| * Copy the factor R into the array R. | |||
| * | |||
| SRNAMT = 'DLACPY' | |||
| CALL DLACPY( 'U', N, N, AF, M, R, M ) | |||
| * | |||
| * Reconstruct the orthogonal matrix Q. | |||
| * | |||
| SRNAMT = 'DORGTSQR' | |||
| CALL DORGTSQR( M, N, MB1, NB1, AF, M, T1, NB1, WORK, LWORK, | |||
| $ INFO ) | |||
| * | |||
| * Perform the Householder reconstruction, the result is stored | |||
| * the arrays AF and T2. | |||
| * | |||
| SRNAMT = 'DORHR_COL' | |||
| CALL DORHR_COL( M, N, NB2, AF, M, T2, NB2, DIAG, INFO ) | |||
| * | |||
| * Compute the factor R_hr corresponding to the Householder | |||
| * reconstructed Q_hr and place it in the upper triangle of AF to | |||
| * match the Q storage format in DGEQRT. R_hr = R_tsqr * S, | |||
| * this means changing the sign of I-th row of the matrix R_tsqr | |||
| * according to sign of of I-th diagonal element DIAG(I) of the | |||
| * matrix S. | |||
| * | |||
| SRNAMT = 'DLACPY' | |||
| CALL DLACPY( 'U', N, N, R, M, AF, M ) | |||
| * | |||
| DO I = 1, N | |||
| IF( DIAG( I ).EQ.-ONE ) THEN | |||
| CALL DSCAL( N+1-I, -ONE, AF( I, I ), M ) | |||
| END IF | |||
| END DO | |||
| * | |||
| * End Householder reconstruction routines. | |||
| * | |||
| * | |||
| * Generate the m-by-m matrix Q | |||
| * | |||
| CALL DLASET( 'Full', M, M, ZERO, ONE, Q, M ) | |||
| * | |||
| SRNAMT = 'DGEMQRT' | |||
| CALL DGEMQRT( 'L', 'N', M, M, K, NB2_UB, AF, M, T2, NB2, Q, M, | |||
| $ WORK, INFO ) | |||
| * | |||
| * Copy R | |||
| * | |||
| CALL DLASET( 'Full', M, N, ZERO, ZERO, R, M ) | |||
| * | |||
| CALL DLACPY( 'Upper', M, N, AF, M, R, M ) | |||
| * | |||
| * TEST 1 | |||
| * Compute |R - (Q**T)*A| / ( eps * m * |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 | |||
| * | |||
| * TEST 2 | |||
| * Compute |I - (Q**T)*Q| / ( eps * m ) and store in RESULT(2) | |||
| * | |||
| CALL DLASET( 'Full', M, M, ZERO, ONE, R, M ) | |||
| CALL DSYRK( 'U', 'T', 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 | |||
| * | |||
| 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 = CF | |||
| * | |||
| SRNAMT = 'DGEMQRT' | |||
| CALL DGEMQRT( 'L', 'N', M, N, K, NB2_UB, AF, M, T2, NB2, CF, M, | |||
| $ WORK, INFO ) | |||
| * | |||
| * TEST 3 | |||
| * Compute |CF - Q*C| / ( eps * m * |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 (Q**T)*C = CF | |||
| * | |||
| SRNAMT = 'DGEMQRT' | |||
| CALL DGEMQRT( 'L', 'T', M, N, K, NB2_UB, AF, M, T2, NB2, CF, M, | |||
| $ WORK, INFO ) | |||
| * | |||
| * TEST 4 | |||
| * Compute |CF - (Q**T)*C| / ( eps * m * |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 = DF | |||
| * | |||
| SRNAMT = 'DGEMQRT' | |||
| CALL DGEMQRT( 'R', 'N', N, M, K, NB2_UB, AF, M, T2, NB2, DF, N, | |||
| $ WORK, INFO ) | |||
| * | |||
| * TEST 5 | |||
| * Compute |DF - D*Q| / ( eps * m * |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 = DF | |||
| * | |||
| SRNAMT = 'DGEMQRT' | |||
| CALL DGEMQRT( 'R', 'T', N, M, K, NB2_UB, AF, M, T2, NB2, DF, N, | |||
| $ WORK, INFO ) | |||
| * | |||
| * TEST 6 | |||
| * Compute |DF - D*(Q**T)| / ( eps * m * |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( DNORM.GT.ZERO ) THEN | |||
| RESULT( 6 ) = RESID / ( EPS * MAX( 1, M ) * DNORM ) | |||
| ELSE | |||
| RESULT( 6 ) = ZERO | |||
| END IF | |||
| * | |||
| * Deallocate all arrays | |||
| * | |||
| DEALLOCATE ( A, AF, Q, R, RWORK, WORK, T1, T2, DIAG, | |||
| $ C, D, CF, DF ) | |||
| * | |||
| RETURN | |||
| * | |||
| * End of DORHR_COL01 | |||
| * | |||
| END | |||
+ 13
- 13
lapack-netlib/TESTING/LIN/dtsqr01.f
View File
| @@ -115,7 +115,7 @@ | |||
| * .. | |||
| * .. Local Arrays .. | |||
| INTEGER ISEED( 4 ) | |||
| DOUBLE PRECISION TQUERY( 5 ), WORKQUERY | |||
| DOUBLE PRECISION TQUERY( 5 ), WORKQUERY( 1 ) | |||
| * .. | |||
| * .. External Functions .. | |||
| DOUBLE PRECISION DLAMCH, DLANGE, DLANSY | |||
| @@ -174,22 +174,22 @@ | |||
| * | |||
| CALL DGEQR( M, N, AF, M, TQUERY, -1, WORKQUERY, -1, INFO ) | |||
| TSIZE = INT( TQUERY( 1 ) ) | |||
| LWORK = INT( WORKQUERY ) | |||
| LWORK = INT( WORKQUERY( 1 ) ) | |||
| CALL DGEMQR( 'L', 'N', M, M, K, AF, M, TQUERY, TSIZE, CF, M, | |||
| $ WORKQUERY, -1, INFO) | |||
| LWORK = MAX( LWORK, INT( WORKQUERY ) ) | |||
| LWORK = MAX( LWORK, INT( WORKQUERY( 1 ) ) ) | |||
| CALL DGEMQR( 'L', 'N', M, N, K, AF, M, TQUERY, TSIZE, CF, M, | |||
| $ WORKQUERY, -1, INFO) | |||
| LWORK = MAX( LWORK, INT( WORKQUERY ) ) | |||
| LWORK = MAX( LWORK, INT( WORKQUERY( 1 ) ) ) | |||
| CALL DGEMQR( 'L', 'T', M, N, K, AF, M, TQUERY, TSIZE, CF, M, | |||
| $ WORKQUERY, -1, INFO) | |||
| LWORK = MAX( LWORK, INT( WORKQUERY ) ) | |||
| LWORK = MAX( LWORK, INT( WORKQUERY( 1 ) ) ) | |||
| CALL DGEMQR( 'R', 'N', N, M, K, AF, M, TQUERY, TSIZE, DF, N, | |||
| $ WORKQUERY, -1, INFO) | |||
| LWORK = MAX( LWORK, INT( WORKQUERY ) ) | |||
| LWORK = MAX( LWORK, INT( WORKQUERY( 1 ) ) ) | |||
| CALL DGEMQR( 'R', 'T', N, M, K, AF, M, TQUERY, TSIZE, DF, N, | |||
| $ WORKQUERY, -1, INFO) | |||
| LWORK = MAX( LWORK, INT( WORKQUERY ) ) | |||
| LWORK = MAX( LWORK, INT( WORKQUERY( 1 ) ) ) | |||
| ALLOCATE ( T( TSIZE ) ) | |||
| ALLOCATE ( WORK( LWORK ) ) | |||
| srnamt = 'DGEQR' | |||
| @@ -317,22 +317,22 @@ | |||
| ELSE | |||
| CALL DGELQ( M, N, AF, M, TQUERY, -1, WORKQUERY, -1, INFO ) | |||
| TSIZE = INT( TQUERY( 1 ) ) | |||
| LWORK = INT( WORKQUERY ) | |||
| LWORK = INT( WORKQUERY( 1 ) ) | |||
| CALL DGEMLQ( 'R', 'N', N, N, K, AF, M, TQUERY, TSIZE, Q, N, | |||
| $ WORKQUERY, -1, INFO ) | |||
| LWORK = MAX( LWORK, INT( WORKQUERY ) ) | |||
| LWORK = MAX( LWORK, INT( WORKQUERY( 1 ) ) ) | |||
| CALL DGEMLQ( 'L', 'N', N, M, K, AF, M, TQUERY, TSIZE, DF, N, | |||
| $ WORKQUERY, -1, INFO) | |||
| LWORK = MAX( LWORK, INT( WORKQUERY ) ) | |||
| LWORK = MAX( LWORK, INT( WORKQUERY( 1 ) ) ) | |||
| CALL DGEMLQ( 'L', 'T', N, M, K, AF, M, TQUERY, TSIZE, DF, N, | |||
| $ WORKQUERY, -1, INFO) | |||
| LWORK = MAX( LWORK, INT( WORKQUERY ) ) | |||
| LWORK = MAX( LWORK, INT( WORKQUERY( 1 ) ) ) | |||
| CALL DGEMLQ( 'R', 'N', M, N, K, AF, M, TQUERY, TSIZE, CF, M, | |||
| $ WORKQUERY, -1, INFO) | |||
| LWORK = MAX( LWORK, INT( WORKQUERY ) ) | |||
| LWORK = MAX( LWORK, INT( WORKQUERY( 1 ) ) ) | |||
| CALL DGEMLQ( 'R', 'T', M, N, K, AF, M, TQUERY, TSIZE, CF, M, | |||
| $ WORKQUERY, -1, INFO) | |||
| LWORK = MAX( LWORK, INT( WORKQUERY ) ) | |||
| LWORK = MAX( LWORK, INT( WORKQUERY( 1 ) ) ) | |||
| ALLOCATE ( T( TSIZE ) ) | |||
| ALLOCATE ( WORK( LWORK ) ) | |||
| srnamt = 'DGELQ' | |||
+ 24
- 11
lapack-netlib/TESTING/LIN/schkaa.f
View File
| @@ -68,6 +68,8 @@ | |||
| *> SEQ | |||
| *> SQT | |||
| *> SQX | |||
| *> STS | |||
| *> SHH | |||
| *> \endverbatim | |||
| * | |||
| * Parameters: | |||
| @@ -102,17 +104,17 @@ | |||
| *> \author Univ. of Colorado Denver | |||
| *> \author NAG Ltd. | |||
| * | |||
| *> \date April 2012 | |||
| *> \date November 2019 | |||
| * | |||
| *> \ingroup single_lin | |||
| * | |||
| * ===================================================================== | |||
| PROGRAM SCHKAA | |||
| * | |||
| * -- LAPACK test routine (version 3.8.0) -- | |||
| * -- LAPACK test routine (version 3.9.0) -- | |||
| * -- LAPACK is a software package provided by Univ. of Tennessee, -- | |||
| * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- | |||
| * April 2012 | |||
| * November 2019 | |||
| * | |||
| * ===================================================================== | |||
| * | |||
| @@ -159,13 +161,13 @@ | |||
| * .. | |||
| * .. External Subroutines .. | |||
| EXTERNAL ALAREQ, SCHKEQ, SCHKGB, SCHKGE, SCHKGT, SCHKLQ, | |||
| $ SCHKPB, SCHKPO, SCHKPS, SCHKPP, SCHKPT, SCHKQ3, | |||
| $ SCHKQL, SCHKQR, SCHKRQ, SCHKSP, SCHKSY, | |||
| $ SCHKSY_ROOK, SCHKSY_RK, SCHKSY_AA, SCHKTB, | |||
| $ SCHKTP, SCHKTR, SCHKTZ, SDRVGB, SDRVGE, SDRVGT, | |||
| $ SDRVLS, SDRVPB, SDRVPO, SDRVPP, SDRVPT, SDRVSP, | |||
| $ SDRVSY, SDRVSY_ROOK, SDRVSY_RK, SDRVSY_AA, | |||
| $ ILAVER, SCHKLQTP, SCHKQRT, SCHKQRTP, | |||
| $ SCHKORHR_COL, SCHKPB, SCHKPO, SCHKPS, SCHKPP, | |||
| $ SCHKPT, SCHKQ3, SCHKQL, SCHKQR, SCHKRQ, SCHKSP, | |||
| $ SCHKSY, SCHKSY_ROOK, SCHKSY_RK, SCHKSY_AA, | |||
| $ SCHKTB, SCHKTP, SCHKTR, SCHKTZ, SDRVGB, SDRVGE, | |||
| $ SDRVGT, SDRVLS, SDRVPB, SDRVPO, SDRVPP, SDRVPT, | |||
| $ SDRVSP, SDRVSY, SDRVSY_ROOK, SDRVSY_RK, | |||
| $ SDRVSY_AA, ILAVER, SCHKLQTP, SCHKQRT, SCHKQRTP, | |||
| $ SCHKLQT, SCHKTSQR | |||
| * .. | |||
| * .. Scalars in Common .. | |||
| @@ -673,7 +675,7 @@ | |||
| * | |||
| * SK: symmetric indefinite matrices, | |||
| * with bounded Bunch-Kaufman (rook) pivoting algorithm, | |||
| * differnet matrix storage format than SR path version. | |||
| * different matrix storage format than SR path version. | |||
| * | |||
| NTYPES = 10 | |||
| CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) | |||
| @@ -1004,6 +1006,17 @@ | |||
| ELSE | |||
| WRITE( NOUT, FMT = 9989 )PATH | |||
| END IF | |||
| * | |||
| ELSE IF( LSAMEN( 2, C2, 'HH' ) ) THEN | |||
| * | |||
| * HH: Householder reconstruction for tall-skinny matrices | |||
| * | |||
| IF( TSTCHK ) THEN | |||
| CALL SCHKORHR_COL( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, | |||
| $ NBVAL, NOUT ) | |||
| ELSE | |||
| WRITE( NOUT, FMT = 9989 ) PATH | |||
| END IF | |||
| * | |||
| ELSE | |||
| * | |||
+ 239
- 0
lapack-netlib/TESTING/LIN/schkorhr_col.f
View File
| @@ -0,0 +1,239 @@ | |||
| *> \brief \b SCHKORHR_COL | |||
| * | |||
| * =========== DOCUMENTATION =========== | |||
| * | |||
| * Online html documentation available at | |||
| * http://www.netlib.org/lapack/explore-html/ | |||
| * | |||
| * Definition: | |||
| * =========== | |||
| * | |||
| * SUBROUTINE SCHKORHR_COL( 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 | |||
| *> | |||
| *> SCHKORHR_COL tests SORHR_COL using SLATSQR, SGEMQRT and SORGTSQR. | |||
| *> Therefore, SLATSQR (part of SGEQR), SGEMQRT (part SGEMQR), SORGTSQR | |||
| *> have to be tested before this test. | |||
| *> | |||
| *> \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 2019 | |||
| * | |||
| *> \ingroup sigle_lin | |||
| * | |||
| * ===================================================================== | |||
| SUBROUTINE SCHKORHR_COL( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, | |||
| $ NBVAL, NOUT ) | |||
| IMPLICIT NONE | |||
| * | |||
| * -- LAPACK test routine (version 3.9.0) -- | |||
| * -- LAPACK is a software package provided by Univ. of Tennessee, -- | |||
| * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- | |||
| * June 2019 | |||
| * | |||
| * .. 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(LEN=3) PATH | |||
| INTEGER I, IMB1, INB1, INB2, J, T, M, N, MB1, NB1, | |||
| $ NB2, NFAIL, NERRS, NRUN | |||
| * | |||
| * .. Local Arrays .. | |||
| REAL RESULT( NTESTS ) | |||
| * .. | |||
| * .. External Subroutines .. | |||
| EXTERNAL ALAHD, ALASUM, SERRORHR_COL, SORHR_COL01 | |||
| * .. | |||
| * .. Intrinsic Functions .. | |||
| INTRINSIC MAX, MIN | |||
| * .. | |||
| * .. Scalars in Common .. | |||
| LOGICAL LERR, OK | |||
| CHARACTER(LEN=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 ) = 'HH' | |||
| NRUN = 0 | |||
| NFAIL = 0 | |||
| NERRS = 0 | |||
| * | |||
| * Test the error exits | |||
| * | |||
| IF( TSTERR ) CALL SERRORHR_COL( 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 ) | |||
| * | |||
| * Only for M >= N | |||
| * | |||
| IF ( MIN( M, N ).GT.0 .AND. M.GE.N ) THEN | |||
| * | |||
| * Do for each possible value of MB1 | |||
| * | |||
| DO IMB1 = 1, NNB | |||
| MB1 = NBVAL( IMB1 ) | |||
| * | |||
| * Only for MB1 > N | |||
| * | |||
| IF ( MB1.GT.N ) THEN | |||
| * | |||
| * Do for each possible value of NB1 | |||
| * | |||
| DO INB1 = 1, NNB | |||
| NB1 = NBVAL( INB1 ) | |||
| * | |||
| * Do for each possible value of NB2 | |||
| * | |||
| DO INB2 = 1, NNB | |||
| NB2 = NBVAL( INB2 ) | |||
| * | |||
| IF( NB1.GT.0 .AND. NB2.GT.0 ) THEN | |||
| * | |||
| * Test SORHR_COL | |||
| * | |||
| CALL SORHR_COL01( M, N, MB1, NB1, NB2, | |||
| $ 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, MB1, | |||
| $ NB1, NB2, T, RESULT( T ) | |||
| NFAIL = NFAIL + 1 | |||
| END IF | |||
| END DO | |||
| NRUN = NRUN + NTESTS | |||
| END IF | |||
| END DO | |||
| END DO | |||
| END IF | |||
| END DO | |||
| END IF | |||
| END DO | |||
| END DO | |||
| * | |||
| * Print a summary of the results. | |||
| * | |||
| CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) | |||
| * | |||
| 9999 FORMAT( 'M=', I5, ', N=', I5, ', MB1=', I5, | |||
| $ ', NB1=', I5, ', NB2=', I5,' test(', I2, ')=', G12.5 ) | |||
| RETURN | |||
| * | |||
| * End of SCHKORHR_COL | |||
| * | |||
| END | |||
+ 10
- 10
lapack-netlib/TESTING/LIN/sdrvls.f
View File
| @@ -233,8 +233,8 @@ | |||
| REAL EPS, NORMA, NORMB, RCOND | |||
| * .. | |||
| * .. Local Arrays .. | |||
| INTEGER ISEED( 4 ), ISEEDY( 4 ), IWQ | |||
| REAL RESULT( NTESTS ), WQ | |||
| INTEGER ISEED( 4 ), ISEEDY( 4 ), IWQ( 1 ) | |||
| REAL RESULT( NTESTS ), WQ( 1 ) | |||
| * .. | |||
| * .. Allocatable Arrays .. | |||
| REAL, ALLOCATABLE :: WORK (:) | |||
| @@ -358,28 +358,28 @@ | |||
| * | |||
| * Compute workspace needed for SGELS | |||
| CALL SGELS( TRANS, M, N, NRHS, A, LDA, | |||
| $ B, LDB, WQ, -1, INFO ) | |||
| LWORK_SGELS = INT ( WQ ) | |||
| $ B, LDB, WQ( 1 ), -1, INFO ) | |||
| LWORK_SGELS = INT ( WQ( 1 ) ) | |||
| * Compute workspace needed for SGETSLS | |||
| CALL SGETSLS( TRANS, M, N, NRHS, A, LDA, | |||
| $ B, LDB, WQ, -1, INFO ) | |||
| LWORK_SGETSLS = INT( WQ ) | |||
| $ B, LDB, WQ( 1 ), -1, INFO ) | |||
| LWORK_SGETSLS = INT( WQ( 1 ) ) | |||
| ENDDO | |||
| END IF | |||
| * Compute workspace needed for SGELSY | |||
| CALL SGELSY( M, N, NRHS, A, LDA, B, LDB, IWQ, | |||
| $ RCOND, CRANK, WQ, -1, INFO ) | |||
| LWORK_SGELSY = INT( WQ ) | |||
| LWORK_SGELSY = INT( WQ( 1 ) ) | |||
| * Compute workspace needed for SGELSS | |||
| CALL SGELSS( M, N, NRHS, A, LDA, B, LDB, S, | |||
| $ RCOND, CRANK, WQ, -1 , INFO ) | |||
| LWORK_SGELSS = INT( WQ ) | |||
| LWORK_SGELSS = INT( WQ( 1 ) ) | |||
| * Compute workspace needed for SGELSD | |||
| CALL SGELSD( M, N, NRHS, A, LDA, B, LDB, S, | |||
| $ RCOND, CRANK, WQ, -1, IWQ, INFO ) | |||
| LWORK_SGELSD = INT( WQ ) | |||
| LWORK_SGELSD = INT( WQ( 1 ) ) | |||
| * Compute LIWORK workspace needed for SGELSY and SGELSD | |||
| LIWORK = MAX( LIWORK, N, IWQ ) | |||
| LIWORK = MAX( LIWORK, N, IWQ( 1 ) ) | |||
| * Compute LWORK workspace needed for all functions | |||
| LWORK = MAX( LWORK, LWORK_SGELS, LWORK_SGETSLS, | |||
| $ LWORK_SGELSY, LWORK_SGELSS, | |||
+ 164
- 0
lapack-netlib/TESTING/LIN/serrorhr_col.f
View File
| @@ -0,0 +1,164 @@ | |||
| *> \brief \b SERRORHR_COL | |||
| * | |||
| * =========== DOCUMENTATION =========== | |||
| * | |||
| * Online html documentation available at | |||
| * http://www.netlib.org/lapack/explore-html/ | |||
| * | |||
| * Definition: | |||
| * =========== | |||
| * | |||
| * SUBROUTINE SERRORHR_COL( PATH, NUNIT ) | |||
| * | |||
| * .. Scalar Arguments .. | |||
| * CHARACTER*3 PATH | |||
| * INTEGER NUNIT | |||
| * .. | |||
| * | |||
| * | |||
| *> \par Purpose: | |||
| * ============= | |||
| *> | |||
| *> \verbatim | |||
| *> | |||
| *> SERRORHR_COL tests the error exits for SORHR_COL that does | |||
| *> Householder reconstruction from the ouput of tall-skinny | |||
| *> factorization SLATSQR. | |||
| *> \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 2019 | |||
| * | |||
| *> \ingroup singlr_lin | |||
| * | |||
| * ===================================================================== | |||
| SUBROUTINE SERRORHR_COL( PATH, NUNIT ) | |||
| IMPLICIT NONE | |||
| * | |||
| * -- LAPACK test routine (version 3.9.0) -- | |||
| * -- LAPACK is a software package provided by Univ. of Tennessee, -- | |||
| * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- | |||
| * November 2019 | |||
| * | |||
| * .. Scalar Arguments .. | |||
| CHARACTER(LEN=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 ), D(NMAX) | |||
| * .. | |||
| * .. External Subroutines .. | |||
| EXTERNAL ALAESM, CHKXER, SORHR_COL | |||
| * .. | |||
| * .. Scalars in Common .. | |||
| LOGICAL LERR, OK | |||
| CHARACTER(LEN=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.E+0 / REAL( I+J ) | |||
| T( I, J ) = 1.E+0 / REAL( I+J ) | |||
| END DO | |||
| D( J ) = 0.E+0 | |||
| END DO | |||
| OK = .TRUE. | |||
| * | |||
| * Error exits for Householder reconstruction | |||
| * | |||
| * SORHR_COL | |||
| * | |||
| SRNAMT = 'SORHR_COL' | |||
| * | |||
| INFOT = 1 | |||
| CALL SORHR_COL( -1, 0, 1, A, 1, T, 1, D, INFO ) | |||
| CALL CHKXER( 'SORHR_COL', INFOT, NOUT, LERR, OK ) | |||
| * | |||
| INFOT = 2 | |||
| CALL SORHR_COL( 0, -1, 1, A, 1, T, 1, D, INFO ) | |||
| CALL CHKXER( 'SORHR_COL', INFOT, NOUT, LERR, OK ) | |||
| CALL SORHR_COL( 1, 2, 1, A, 1, T, 1, D, INFO ) | |||
| CALL CHKXER( 'SORHR_COL', INFOT, NOUT, LERR, OK ) | |||
| * | |||
| INFOT = 3 | |||
| CALL SORHR_COL( 0, 0, -1, A, 1, T, 1, D, INFO ) | |||
| CALL CHKXER( 'SORHR_COL', INFOT, NOUT, LERR, OK ) | |||
| * | |||
| CALL SORHR_COL( 0, 0, 0, A, 1, T, 1, D, INFO ) | |||
| CALL CHKXER( 'SORHR_COL', INFOT, NOUT, LERR, OK ) | |||
| * | |||
| INFOT = 5 | |||
| CALL SORHR_COL( 0, 0, 1, A, -1, T, 1, D, INFO ) | |||
| CALL CHKXER( 'SORHR_COL', INFOT, NOUT, LERR, OK ) | |||
| * | |||
| CALL SORHR_COL( 0, 0, 1, A, 0, T, 1, D, INFO ) | |||
| CALL CHKXER( 'SORHR_COL', INFOT, NOUT, LERR, OK ) | |||
| * | |||
| CALL SORHR_COL( 2, 0, 1, A, 1, T, 1, D, INFO ) | |||
| CALL CHKXER( 'SORHR_COL', INFOT, NOUT, LERR, OK ) | |||
| * | |||
| INFOT = 7 | |||
| CALL SORHR_COL( 0, 0, 1, A, 1, T, -1, D, INFO ) | |||
| CALL CHKXER( 'SORHR_COL', INFOT, NOUT, LERR, OK ) | |||
| * | |||
| CALL SORHR_COL( 0, 0, 1, A, 1, T, 0, D, INFO ) | |||
| CALL CHKXER( 'SORHR_COL', INFOT, NOUT, LERR, OK ) | |||
| * | |||
| CALL SORHR_COL( 4, 3, 2, A, 4, T, 1, D, INFO ) | |||
| CALL CHKXER( 'SORHR_COL', INFOT, NOUT, LERR, OK ) | |||
| * | |||
| * Print a summary line. | |||
| * | |||
| CALL ALAESM( PATH, OK, NOUT ) | |||
| * | |||
| RETURN | |||
| * | |||
| * End of SERRORHR_COL | |||
| * | |||
| END | |||
+ 1
- 1
lapack-netlib/TESTING/LIN/serrvx.f
View File
| @@ -735,7 +735,7 @@ | |||
| $ W, 1, INFO ) | |||
| CALL CHKXER( 'SSYSV_AA_2STAGE', INFOT, NOUT, LERR, OK ) | |||
| INFOT = 11 | |||
| CALL SSYSV_AA_2STAGE( 'U', 2, 1, A, 2, A, 2, IP, IP, B, 1, | |||
| CALL SSYSV_AA_2STAGE( 'U', 2, 1, A, 2, A, 8, IP, IP, B, 1, | |||
| $ W, 1, INFO ) | |||
| CALL CHKXER( 'SSYSV_AA_2STAGE', INFOT, NOUT, LERR, OK ) | |||
| INFOT = 7 | |||
+ 386
- 0
lapack-netlib/TESTING/LIN/sorhr_col01.f
View File
| @@ -0,0 +1,386 @@ | |||
| *> \brief \b SORHR_COL01 | |||
| * | |||
| * =========== DOCUMENTATION =========== | |||
| * | |||
| * Online html documentation available at | |||
| * http://www.netlib.org/lapack/explore-html/ | |||
| * | |||
| * Definition: | |||
| * =========== | |||
| * | |||
| * SUBROUTINE SORHR_COL01( M, N, MB1, NB1, NB2, RESULT) | |||
| * | |||
| * .. Scalar Arguments .. | |||
| * INTEGER M, N, MB1, NB1, NB2 | |||
| * .. Return values .. | |||
| * REAL RESULT(6) | |||
| * | |||
| * | |||
| *> \par Purpose: | |||
| * ============= | |||
| *> | |||
| *> \verbatim | |||
| *> | |||
| *> SORHR_COL01 tests SORHR_COL using SLATSQR, SGEMQRT and SORGTSQR. | |||
| *> Therefore, SLATSQR (part of SGEQR), SGEMQRT (part SGEMQR), SORGTSQR | |||
| *> have to be tested before this test. | |||
| *> | |||
| *> \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] MB1 | |||
| *> \verbatim | |||
| *> MB1 is INTEGER | |||
| *> Number of row in row block in an input test matrix. | |||
| *> \endverbatim | |||
| *> | |||
| *> \param[in] NB1 | |||
| *> \verbatim | |||
| *> NB1 is INTEGER | |||
| *> Number of columns in column block an input test matrix. | |||
| *> \endverbatim | |||
| *> | |||
| *> \param[in] NB2 | |||
| *> \verbatim | |||
| *> NB2 is INTEGER | |||
| *> Number of columns in column block in an output test matrix. | |||
| *> \endverbatim | |||
| *> | |||
| *> \param[out] RESULT | |||
| *> \verbatim | |||
| *> RESULT is REAL array, dimension (6) | |||
| *> Results of each of the six tests below. | |||
| *> ( C is a M-by-N random matrix, D is a N-by-M random matrix ) | |||
| *> | |||
| *> RESULT(1) = | A - Q * R | / (eps * m * |A|) | |||
| *> RESULT(2) = | I - (Q**H) * Q | / (eps * m ) | |||
| *> RESULT(3) = | Q * C - Q * C | / (eps * m * |C|) | |||
| *> RESULT(4) = | (Q**H) * C - (Q**H) * C | / (eps * m * |C|) | |||
| *> RESULT(5) = | (D * Q) - D * Q | / (eps * m * |D|) | |||
| *> RESULT(6) = | D * (Q**H) - D * (Q**H) | / (eps * m * |D|) | |||
| *> \endverbatim | |||
| * | |||
| * Authors: | |||
| * ======== | |||
| * | |||
| *> \author Univ. of Tennessee | |||
| *> \author Univ. of California Berkeley | |||
| *> \author Univ. of Colorado Denver | |||
| *> \author NAG Ltd. | |||
| * | |||
| *> \date November 2019 | |||
| * | |||
| *> \ingroup single_lin | |||
| * | |||
| * ===================================================================== | |||
| SUBROUTINE SORHR_COL01( M, N, MB1, NB1, NB2, RESULT ) | |||
| IMPLICIT NONE | |||
| * | |||
| * -- LAPACK test routine (version 3.9.0) -- | |||
| * -- LAPACK is a software package provided by Univ. of Tennessee, -- | |||
| * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- | |||
| * November 2019 | |||
| * | |||
| * .. Scalar Arguments .. | |||
| INTEGER M, N, MB1, NB1, NB2 | |||
| * .. Return values .. | |||
| REAL RESULT(6) | |||
| * | |||
| * ===================================================================== | |||
| * | |||
| * .. | |||
| * .. Local allocatable arrays | |||
| REAL, ALLOCATABLE :: A(:,:), AF(:,:), Q(:,:), R(:,:), | |||
| $ RWORK(:), WORK( : ), T1(:,:), T2(:,:), DIAG(:), | |||
| $ C(:,:), CF(:,:), D(:,:), DF(:,:) | |||
| * | |||
| * .. Parameters .. | |||
| REAL ONE, ZERO | |||
| PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) | |||
| * .. | |||
| * .. Local Scalars .. | |||
| LOGICAL TESTZEROS | |||
| INTEGER INFO, I, J, K, L, LWORK, NB1_UB, NB2_UB, NRB | |||
| REAL ANORM, EPS, RESID, CNORM, DNORM | |||
| * .. | |||
| * .. Local Arrays .. | |||
| INTEGER ISEED( 4 ) | |||
| REAL WORKQUERY( 1 ) | |||
| * .. | |||
| * .. External Functions .. | |||
| REAL SLAMCH, SLANGE, SLANSY | |||
| EXTERNAL SLAMCH, SLANGE, SLANSY | |||
| * .. | |||
| * .. External Subroutines .. | |||
| EXTERNAL SLACPY, SLARNV, SLASET, SLATSQR, SORHR_COL, | |||
| $ SORGTSQR, SSCAL, SGEMM, SGEMQRT, SSYRK | |||
| * .. | |||
| * .. Intrinsic Functions .. | |||
| INTRINSIC CEILING, MAX, MIN, REAL | |||
| * .. | |||
| * .. Scalars in Common .. | |||
| CHARACTER(LEN=32) SRNAMT | |||
| * .. | |||
| * .. Common blocks .. | |||
| COMMON / SRMNAMC / SRNAMT | |||
| * .. | |||
| * .. Data statements .. | |||
| DATA ISEED / 1988, 1989, 1990, 1991 / | |||
| * | |||
| * TEST MATRICES WITH HALF OF MATRIX BEING ZEROS | |||
| * | |||
| TESTZEROS = .FALSE. | |||
| * | |||
| EPS = SLAMCH( 'Epsilon' ) | |||
| K = MIN( M, N ) | |||
| L = MAX( M, N, 1) | |||
| * | |||
| * Dynamically allocate local arrays | |||
| * | |||
| ALLOCATE ( A(M,N), AF(M,N), Q(L,L), R(M,L), RWORK(L), | |||
| $ C(M,N), CF(M,N), | |||
| $ D(N,M), DF(N,M) ) | |||
| * | |||
| * 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 ) | |||
| * | |||
| * Number of row blocks in SLATSQR | |||
| * | |||
| NRB = MAX( 1, CEILING( REAL( M - N ) / REAL( MB1 - N ) ) ) | |||
| * | |||
| ALLOCATE ( T1( NB1, N * NRB ) ) | |||
| ALLOCATE ( T2( NB2, N ) ) | |||
| ALLOCATE ( DIAG( N ) ) | |||
| * | |||
| * Begin determine LWORK for the array WORK and allocate memory. | |||
| * | |||
| * SLATSQR requires NB1 to be bounded by N. | |||
| * | |||
| NB1_UB = MIN( NB1, N) | |||
| * | |||
| * SGEMQRT requires NB2 to be bounded by N. | |||
| * | |||
| NB2_UB = MIN( NB2, N) | |||
| * | |||
| CALL SLATSQR( M, N, MB1, NB1_UB, AF, M, T1, NB1, | |||
| $ WORKQUERY, -1, INFO ) | |||
| LWORK = INT( WORKQUERY( 1 ) ) | |||
| CALL SORGTSQR( M, N, MB1, NB1, AF, M, T1, NB1, WORKQUERY, -1, | |||
| $ INFO ) | |||
| LWORK = MAX( LWORK, INT( WORKQUERY( 1 ) ) ) | |||
| * | |||
| * In SGEMQRT, WORK is N*NB2_UB if SIDE = 'L', | |||
| * or M*NB2_UB if SIDE = 'R'. | |||
| * | |||
| LWORK = MAX( LWORK, NB2_UB * N, NB2_UB * M ) | |||
| * | |||
| ALLOCATE ( WORK( LWORK ) ) | |||
| * | |||
| * End allocate memory for WORK. | |||
| * | |||
| * | |||
| * Begin Householder reconstruction routines | |||
| * | |||
| * Factor the matrix A in the array AF. | |||
| * | |||
| SRNAMT = 'SLATSQR' | |||
| CALL SLATSQR( M, N, MB1, NB1_UB, AF, M, T1, NB1, WORK, LWORK, | |||
| $ INFO ) | |||
| * | |||
| * Copy the factor R into the array R. | |||
| * | |||
| SRNAMT = 'SLACPY' | |||
| CALL SLACPY( 'U', N, N, AF, M, R, M ) | |||
| * | |||
| * Reconstruct the orthogonal matrix Q. | |||
| * | |||
| SRNAMT = 'SORGTSQR' | |||
| CALL SORGTSQR( M, N, MB1, NB1, AF, M, T1, NB1, WORK, LWORK, | |||
| $ INFO ) | |||
| * | |||
| * Perform the Householder reconstruction, the result is stored | |||
| * the arrays AF and T2. | |||
| * | |||
| SRNAMT = 'SORHR_COL' | |||
| CALL SORHR_COL( M, N, NB2, AF, M, T2, NB2, DIAG, INFO ) | |||
| * | |||
| * Compute the factor R_hr corresponding to the Householder | |||
| * reconstructed Q_hr and place it in the upper triangle of AF to | |||
| * match the Q storage format in DGEQRT. R_hr = R_tsqr * S, | |||
| * this means changing the sign of I-th row of the matrix R_tsqr | |||
| * according to sign of of I-th diagonal element DIAG(I) of the | |||
| * matrix S. | |||
| * | |||
| SRNAMT = 'SLACPY' | |||
| CALL SLACPY( 'U', N, N, R, M, AF, M ) | |||
| * | |||
| DO I = 1, N | |||
| IF( DIAG( I ).EQ.-ONE ) THEN | |||
| CALL SSCAL( N+1-I, -ONE, AF( I, I ), M ) | |||
| END IF | |||
| END DO | |||
| * | |||
| * End Householder reconstruction routines. | |||
| * | |||
| * | |||
| * Generate the m-by-m matrix Q | |||
| * | |||
| CALL SLASET( 'Full', M, M, ZERO, ONE, Q, M ) | |||
| * | |||
| SRNAMT = 'SGEMQRT' | |||
| CALL SGEMQRT( 'L', 'N', M, M, K, NB2_UB, AF, M, T2, NB2, Q, M, | |||
| $ WORK, INFO ) | |||
| * | |||
| * Copy R | |||
| * | |||
| CALL SLASET( 'Full', M, N, ZERO, ZERO, R, M ) | |||
| * | |||
| CALL SLACPY( 'Upper', M, N, AF, M, R, M ) | |||
| * | |||
| * TEST 1 | |||
| * Compute |R - (Q**T)*A| / ( eps * m * |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 | |||
| * | |||
| * TEST 2 | |||
| * Compute |I - (Q**T)*Q| / ( eps * m ) and store in RESULT(2) | |||
| * | |||
| CALL SLASET( 'Full', M, M, ZERO, ONE, R, M ) | |||
| CALL SSYRK( 'U', 'T', 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 | |||
| * | |||
| 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 = CF | |||
| * | |||
| SRNAMT = 'SGEMQRT' | |||
| CALL SGEMQRT( 'L', 'N', M, N, K, NB2_UB, AF, M, T2, NB2, CF, M, | |||
| $ WORK, INFO ) | |||
| * | |||
| * TEST 3 | |||
| * Compute |CF - Q*C| / ( eps * m * |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 (Q**T)*C = CF | |||
| * | |||
| SRNAMT = 'SGEMQRT' | |||
| CALL SGEMQRT( 'L', 'T', M, N, K, NB2_UB, AF, M, T2, NB2, CF, M, | |||
| $ WORK, INFO ) | |||
| * | |||
| * TEST 4 | |||
| * Compute |CF - (Q**T)*C| / ( eps * m * |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 = DF | |||
| * | |||
| SRNAMT = 'SGEMQRT' | |||
| CALL SGEMQRT( 'R', 'N', N, M, K, NB2_UB, AF, M, T2, NB2, DF, N, | |||
| $ WORK, INFO ) | |||
| * | |||
| * TEST 5 | |||
| * Compute |DF - D*Q| / ( eps * m * |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 = DF | |||
| * | |||
| SRNAMT = 'SGEMQRT' | |||
| CALL SGEMQRT( 'R', 'T', N, M, K, NB2_UB, AF, M, T2, NB2, DF, N, | |||
| $ WORK, INFO ) | |||
| * | |||
| * TEST 6 | |||
| * Compute |DF - D*(Q**T)| / ( eps * m * |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( DNORM.GT.ZERO ) THEN | |||
| RESULT( 6 ) = RESID / ( EPS * MAX( 1, M ) * DNORM ) | |||
| ELSE | |||
| RESULT( 6 ) = ZERO | |||
| END IF | |||
| * | |||
| * Deallocate all arrays | |||
| * | |||
| DEALLOCATE ( A, AF, Q, R, RWORK, WORK, T1, T2, DIAG, | |||
| $ C, D, CF, DF ) | |||
| * | |||
| RETURN | |||
| * | |||
| * End of SORHR_COL01 | |||
| * | |||
| END | |||
+ 13
- 13
lapack-netlib/TESTING/LIN/stsqr01.f
View File
| @@ -115,7 +115,7 @@ | |||
| * .. | |||
| * .. Local Arrays .. | |||
| INTEGER ISEED( 4 ) | |||
| REAL TQUERY( 5 ), WORKQUERY | |||
| REAL TQUERY( 5 ), WORKQUERY( 1 ) | |||
| * .. | |||
| * .. External Functions .. | |||
| REAL SLAMCH, SLANGE, SLANSY | |||
| @@ -174,22 +174,22 @@ | |||
| * | |||
| CALL SGEQR( M, N, AF, M, TQUERY, -1, WORKQUERY, -1, INFO ) | |||
| TSIZE = INT( TQUERY( 1 ) ) | |||
| LWORK = INT( WORKQUERY ) | |||
| LWORK = INT( WORKQUERY( 1 ) ) | |||
| CALL SGEMQR( 'L', 'N', M, M, K, AF, M, TQUERY, TSIZE, CF, M, | |||
| $ WORKQUERY, -1, INFO) | |||
| LWORK = MAX( LWORK, INT( WORKQUERY ) ) | |||
| LWORK = MAX( LWORK, INT( WORKQUERY( 1 ) ) ) | |||
| CALL SGEMQR( 'L', 'N', M, N, K, AF, M, TQUERY, TSIZE, CF, M, | |||
| $ WORKQUERY, -1, INFO) | |||
| LWORK = MAX( LWORK, INT( WORKQUERY ) ) | |||
| LWORK = MAX( LWORK, INT( WORKQUERY( 1 ) ) ) | |||
| CALL SGEMQR( 'L', 'T', M, N, K, AF, M, TQUERY, TSIZE, CF, M, | |||
| $ WORKQUERY, -1, INFO) | |||
| LWORK = MAX( LWORK, INT( WORKQUERY ) ) | |||
| LWORK = MAX( LWORK, INT( WORKQUERY( 1 ) ) ) | |||
| CALL SGEMQR( 'R', 'N', N, M, K, AF, M, TQUERY, TSIZE, DF, N, | |||
| $ WORKQUERY, -1, INFO) | |||
| LWORK = MAX( LWORK, INT( WORKQUERY ) ) | |||
| LWORK = MAX( LWORK, INT( WORKQUERY( 1 ) ) ) | |||
| CALL SGEMQR( 'R', 'T', N, M, K, AF, M, TQUERY, TSIZE, DF, N, | |||
| $ WORKQUERY, -1, INFO) | |||
| LWORK = MAX( LWORK, INT( WORKQUERY ) ) | |||
| LWORK = MAX( LWORK, INT( WORKQUERY( 1 ) ) ) | |||
| ALLOCATE ( T( TSIZE ) ) | |||
| ALLOCATE ( WORK( LWORK ) ) | |||
| srnamt = 'SGEQR' | |||
| @@ -317,22 +317,22 @@ | |||
| ELSE | |||
| CALL SGELQ( M, N, AF, M, TQUERY, -1, WORKQUERY, -1, INFO ) | |||
| TSIZE = INT( TQUERY( 1 ) ) | |||
| LWORK = INT( WORKQUERY ) | |||
| LWORK = INT( WORKQUERY( 1 )) | |||
| CALL SGEMLQ( 'R', 'N', N, N, K, AF, M, TQUERY, TSIZE, Q, N, | |||
| $ WORKQUERY, -1, INFO ) | |||
| LWORK = MAX( LWORK, INT( WORKQUERY ) ) | |||
| LWORK = MAX( LWORK, INT( WORKQUERY( 1 ) ) ) | |||
| CALL SGEMLQ( 'L', 'N', N, M, K, AF, M, TQUERY, TSIZE, DF, N, | |||
| $ WORKQUERY, -1, INFO) | |||
| LWORK = MAX( LWORK, INT( WORKQUERY ) ) | |||
| LWORK = MAX( LWORK, INT( WORKQUERY( 1 ) ) ) | |||
| CALL SGEMLQ( 'L', 'T', N, M, K, AF, M, TQUERY, TSIZE, DF, N, | |||
| $ WORKQUERY, -1, INFO) | |||
| LWORK = MAX( LWORK, INT( WORKQUERY ) ) | |||
| LWORK = MAX( LWORK, INT( WORKQUERY( 1 ) ) ) | |||
| CALL SGEMLQ( 'R', 'N', M, N, K, AF, M, TQUERY, TSIZE, CF, M, | |||
| $ WORKQUERY, -1, INFO) | |||
| LWORK = MAX( LWORK, INT( WORKQUERY ) ) | |||
| LWORK = MAX( LWORK, INT( WORKQUERY( 1 ) ) ) | |||
| CALL SGEMLQ( 'R', 'T', M, N, K, AF, M, TQUERY, TSIZE, CF, M, | |||
| $ WORKQUERY, -1, INFO) | |||
| LWORK = MAX( LWORK, INT( WORKQUERY ) ) | |||
| LWORK = MAX( LWORK, INT( WORKQUERY( 1 ) ) ) | |||
| ALLOCATE ( T( TSIZE ) ) | |||
| ALLOCATE ( WORK( LWORK ) ) | |||
| srnamt = 'SGELQ' | |||
+ 28
- 15
lapack-netlib/TESTING/LIN/zchkaa.f
View File
| @@ -74,6 +74,8 @@ | |||
| *> ZEQ | |||
| *> ZQT | |||
| *> ZQX | |||
| *> ZTS | |||
| *> ZHH | |||
| *> \endverbatim | |||
| * | |||
| * Parameters: | |||
| @@ -108,17 +110,17 @@ | |||
| *> \author Univ. of Colorado Denver | |||
| *> \author NAG Ltd. | |||
| * | |||
| *> \date November 2017 | |||
| *> \date November 2019 | |||
| * | |||
| *> \ingroup complex16_lin | |||
| * | |||
| * ===================================================================== | |||
| PROGRAM ZCHKAA | |||
| * | |||
| * -- LAPACK test routine (version 3.8.0) -- | |||
| * -- LAPACK test routine (version 3.9.0) -- | |||
| * -- LAPACK is a software package provided by Univ. of Tennessee, -- | |||
| * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- | |||
| * November 2017 | |||
| * November 2019 | |||
| * | |||
| * ===================================================================== | |||
| * | |||
| @@ -166,16 +168,16 @@ | |||
| * .. External Subroutines .. | |||
| EXTERNAL ALAREQ, ZCHKEQ, ZCHKGB, ZCHKGE, ZCHKGT, ZCHKHE, | |||
| $ ZCHKHE_ROOK, ZCHKHE_RK, ZCHKHE_AA, ZCHKHP, | |||
| $ ZCHKLQ, ZCHKPB, ZCHKPO, ZCHKPS, ZCHKPP, ZCHKPT, | |||
| $ ZCHKQ3, ZCHKQL, ZCHKQR, ZCHKRQ, ZCHKSP, ZCHKSY, | |||
| $ ZCHKSY_ROOK, ZCHKSY_RK, ZCHKSY_AA, ZCHKTB, | |||
| $ ZCHKTP, ZCHKTR, ZCHKTZ, ZDRVGB, ZDRVGE, ZDRVGT, | |||
| $ ZDRVHE, ZDRVHE_ROOK, ZDRVHE_RK, ZDRVHE_AA, | |||
| $ ZDRVHE_AA_2STAGE, ZDRVHP, ZDRVLS, ZDRVPB, | |||
| $ ZDRVPO, ZDRVPP, ZDRVPT, ZDRVSP, ZDRVSY, | |||
| $ ZDRVSY_ROOK, ZDRVSY_RK, ZDRVSY_AA, | |||
| $ ZDRVSY_AA_2STAGE, ILAVER, ZCHKQRT, ZCHKQRTP, | |||
| $ ZCHKLQT, ZCHKLQTP, ZCHKTSQR | |||
| $ ZCHKLQ, ZCHKUNHR_COL, ZCHKPB, ZCHKPO, ZCHKPS, | |||
| $ ZCHKPP, ZCHKPT, ZCHKQ3, ZCHKQL, ZCHKQR, ZCHKRQ, | |||
| $ ZCHKSP, ZCHKSY, ZCHKSY_ROOK, ZCHKSY_RK, | |||
| $ ZCHKSY_AA, ZCHKTB, ZCHKTP, ZCHKTR, ZCHKTZ, | |||
| $ ZDRVGB, ZDRVGE, ZDRVGT, ZDRVHE, ZDRVHE_ROOK, | |||
| $ ZDRVHE_RK, ZDRVHE_AA, ZDRVHE_AA_2STAGE, ZDRVHP, | |||
| $ ZDRVLS, ZDRVPB, ZDRVPO, ZDRVPP, ZDRVPT, | |||
| $ ZDRVSP, ZDRVSY, ZDRVSY_ROOK, ZDRVSY_RK, | |||
| $ ZDRVSY_AA, ZDRVSY_AA_2STAGE, ILAVER, ZCHKQRT, | |||
| $ ZCHKQRTP, ZCHKLQT, ZCHKLQTP, ZCHKTSQR | |||
| * .. | |||
| * .. Scalars in Common .. | |||
| LOGICAL LERR, OK | |||
| @@ -679,7 +681,7 @@ | |||
| * | |||
| * HK: Hermitian indefinite matrices, | |||
| * with bounded Bunch-Kaufman (rook) pivoting algorithm, | |||
| * differnet matrix storage format than HR path version. | |||
| * different matrix storage format than HR path version. | |||
| * | |||
| NTYPES = 10 | |||
| CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) | |||
| @@ -839,7 +841,7 @@ | |||
| * | |||
| * SK: symmetric indefinite matrices, | |||
| * with bounded Bunch-Kaufman (rook) pivoting algorithm, | |||
| * differnet matrix storage format than SR path version. | |||
| * different matrix storage format than SR path version. | |||
| * | |||
| NTYPES = 11 | |||
| CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) | |||
| @@ -1201,6 +1203,17 @@ | |||
| ELSE | |||
| WRITE( NOUT, FMT = 9989 )PATH | |||
| END IF | |||
| * | |||
| ELSE IF( LSAMEN( 2, C2, 'HH' ) ) THEN | |||
| * | |||
| * HH: Householder reconstruction for tall-skinny matrices | |||
| * | |||
| IF( TSTCHK ) THEN | |||
| CALL ZCHKUNHR_COL( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, | |||
| $ NBVAL, NOUT ) | |||
| ELSE | |||
| WRITE( NOUT, FMT = 9989 ) PATH | |||
| END IF | |||
| * | |||
| ELSE | |||
| * | |||
+ 239
- 0
lapack-netlib/TESTING/LIN/zchkunhr_col.f
View File
| @@ -0,0 +1,239 @@ | |||
| *> \brief \b ZCHKUNHR_COL | |||
| * | |||
| * =========== DOCUMENTATION =========== | |||
| * | |||
| * Online html documentation available at | |||
| * http://www.netlib.org/lapack/explore-html/ | |||
| * | |||
| * Definition: | |||
| * =========== | |||
| * | |||
| * SUBROUTINE ZCHKUNHR_COL( 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 | |||
| *> | |||
| *> ZCHKUNHR_COL tests ZUNHR_COL using ZLATSQR and ZGEMQRT. Therefore, ZLATSQR | |||
| *> (used in ZGEQR) and ZGEMQRT (used in ZGEMQR) have to be tested | |||
| *> before this test. | |||
| *> | |||
| *> \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 2019 | |||
| * | |||
| *> \ingroup complex16_lin | |||
| * | |||
| * ===================================================================== | |||
| SUBROUTINE ZCHKUNHR_COL( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, | |||
| $ NBVAL, NOUT ) | |||
| IMPLICIT NONE | |||
| * | |||
| * -- LAPACK test routine (version 3.7.0) -- | |||
| * -- LAPACK is a software package provided by Univ. of Tennessee, -- | |||
| * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- | |||
| * December 2016 | |||
| * | |||
| * .. 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(LEN=3) PATH | |||
| INTEGER I, IMB1, INB1, INB2, J, T, M, N, MB1, NB1, | |||
| $ NB2, NFAIL, NERRS, NRUN | |||
| * | |||
| * .. Local Arrays .. | |||
| DOUBLE PRECISION RESULT( NTESTS ) | |||
| * .. | |||
| * .. External Subroutines .. | |||
| EXTERNAL ALAHD, ALASUM, ZERRUNHR_COL, ZUNHR_COL01 | |||
| * .. | |||
| * .. Intrinsic Functions .. | |||
| INTRINSIC MAX, MIN | |||
| * .. | |||
| * .. Scalars in Common .. | |||
| LOGICAL LERR, OK | |||
| CHARACTER(LEN=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 ) = 'HH' | |||
| NRUN = 0 | |||
| NFAIL = 0 | |||
| NERRS = 0 | |||
| * | |||
| * Test the error exits | |||
| * | |||
| IF( TSTERR ) CALL ZERRUNHR_COL( 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 ) | |||
| * | |||
| * Only for M >= N | |||
| * | |||
| IF ( MIN( M, N ).GT.0 .AND. M.GE.N ) THEN | |||
| * | |||
| * Do for each possible value of MB1 | |||
| * | |||
| DO IMB1 = 1, NNB | |||
| MB1 = NBVAL( IMB1 ) | |||
| * | |||
| * Only for MB1 > N | |||
| * | |||
| IF ( MB1.GT.N ) THEN | |||
| * | |||
| * Do for each possible value of NB1 | |||
| * | |||
| DO INB1 = 1, NNB | |||
| NB1 = NBVAL( INB1 ) | |||
| * | |||
| * Do for each possible value of NB2 | |||
| * | |||
| DO INB2 = 1, NNB | |||
| NB2 = NBVAL( INB2 ) | |||
| * | |||
| IF( NB1.GT.0 .AND. NB2.GT.0 ) THEN | |||
| * | |||
| * Test ZUNHR_COL | |||
| * | |||
| CALL ZUNHR_COL01( M, N, MB1, NB1, NB2, | |||
| $ 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, MB1, | |||
| $ NB1, NB2, T, RESULT( T ) | |||
| NFAIL = NFAIL + 1 | |||
| END IF | |||
| END DO | |||
| NRUN = NRUN + NTESTS | |||
| END IF | |||
| END DO | |||
| END DO | |||
| END IF | |||
| END DO | |||
| END IF | |||
| END DO | |||
| END DO | |||
| * | |||
| * Print a summary of the results. | |||
| * | |||
| CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) | |||
| * | |||
| 9999 FORMAT( 'M=', I5, ', N=', I5, ', MB1=', I5, | |||
| $ ', NB1=', I5, ', NB2=', I5,' test(', I2, ')=', G12.5 ) | |||
| RETURN | |||
| * | |||
| * End of ZCHKUNHR_COL | |||
| * | |||
| END | |||
+ 1
- 0
lapack-netlib/TESTING/LIN/zdrvhe_rk.f
View File
| @@ -98,6 +98,7 @@ | |||
| *> \param[out] E | |||
| *> \verbatim | |||
| *> E is COMPLEX*16 array, dimension (NMAX) | |||
| *> \endverbatim | |||
| *> | |||
| *> \param[out] AINV | |||
| *> \verbatim | |||
+ 13
- 12
lapack-netlib/TESTING/LIN/zdrvls.f
View File
| @@ -237,13 +237,13 @@ | |||
| DOUBLE PRECISION EPS, NORMA, NORMB, RCOND | |||
| * .. | |||
| * .. Local Arrays .. | |||
| INTEGER ISEED( 4 ), ISEEDY( 4 ), IWQ | |||
| DOUBLE PRECISION RESULT( NTESTS ), RWQ | |||
| COMPLEX*16 WQ | |||
| INTEGER ISEED( 4 ), ISEEDY( 4 ), IWQ( 1 ) | |||
| DOUBLE PRECISION RESULT( NTESTS ), RWQ( 1 ) | |||
| COMPLEX*16 WQ( 1 ) | |||
| * .. | |||
| * .. Allocatable Arrays .. | |||
| COMPLEX*16, ALLOCATABLE :: WORK (:) | |||
| DOUBLE PRECISION, ALLOCATABLE :: RWORK (:) | |||
| DOUBLE PRECISION, ALLOCATABLE :: RWORK (:), WORK2 (:) | |||
| INTEGER, ALLOCATABLE :: IWORK (:) | |||
| * .. | |||
| * .. External Functions .. | |||
| @@ -363,32 +363,32 @@ | |||
| * Compute workspace needed for ZGELS | |||
| CALL ZGELS( TRANS, M, N, NRHS, A, LDA, | |||
| $ B, LDB, WQ, -1, INFO ) | |||
| LWORK_ZGELS = INT ( WQ ) | |||
| LWORK_ZGELS = INT ( WQ( 1 ) ) | |||
| * Compute workspace needed for ZGETSLS | |||
| CALL ZGETSLS( TRANS, M, N, NRHS, A, LDA, | |||
| $ B, LDB, WQ, -1, INFO ) | |||
| LWORK_ZGETSLS = INT( WQ ) | |||
| LWORK_ZGETSLS = INT( WQ( 1 ) ) | |||
| ENDDO | |||
| END IF | |||
| * Compute workspace needed for ZGELSY | |||
| CALL ZGELSY( M, N, NRHS, A, LDA, B, LDB, IWQ, | |||
| $ RCOND, CRANK, WQ, -1, RWORK, INFO ) | |||
| LWORK_ZGELSY = INT( WQ ) | |||
| LWORK_ZGELSY = INT( WQ( 1 ) ) | |||
| LRWORK_ZGELSY = 2*N | |||
| * Compute workspace needed for ZGELSS | |||
| CALL ZGELSS( M, N, NRHS, A, LDA, B, LDB, S, | |||
| $ RCOND, CRANK, WQ, -1 , RWORK, | |||
| $ INFO ) | |||
| LWORK_ZGELSS = INT( WQ ) | |||
| LWORK_ZGELSS = INT( WQ( 1 ) ) | |||
| LRWORK_ZGELSS = 5*MNMIN | |||
| * Compute workspace needed for ZGELSD | |||
| CALL ZGELSD( M, N, NRHS, A, LDA, B, LDB, S, | |||
| $ RCOND, CRANK, WQ, -1, RWQ, IWQ, | |||
| $ INFO ) | |||
| LWORK_ZGELSD = INT( WQ ) | |||
| LRWORK_ZGELSD = INT( RWQ ) | |||
| LWORK_ZGELSD = INT( WQ( 1 ) ) | |||
| LRWORK_ZGELSD = INT( RWQ ( 1 ) ) | |||
| * Compute LIWORK workspace needed for ZGELSY and ZGELSD | |||
| LIWORK = MAX( LIWORK, N, IWQ ) | |||
| LIWORK = MAX( LIWORK, N, IWQ( 1 ) ) | |||
| * Compute LRWORK workspace needed for ZGELSY, ZGELSS and ZGELSD | |||
| LRWORK = MAX( LRWORK, LRWORK_ZGELSY, | |||
| $ LRWORK_ZGELSS, LRWORK_ZGELSD ) | |||
| @@ -406,6 +406,7 @@ | |||
| LWLSY = LWORK | |||
| * | |||
| ALLOCATE( WORK( LWORK ) ) | |||
| ALLOCATE( WORK2( 2 * LWORK ) ) | |||
| ALLOCATE( IWORK( LIWORK ) ) | |||
| ALLOCATE( RWORK( LRWORK ) ) | |||
| * | |||
| @@ -596,7 +597,7 @@ | |||
| $ CALL ZLACPY( 'Full', NROWS, NRHS, | |||
| $ COPYB, LDB, C, LDB ) | |||
| CALL ZQRT16( TRANS, M, N, NRHS, COPYA, | |||
| $ LDA, B, LDB, C, LDB, WORK, | |||
| $ LDA, B, LDB, C, LDB, WORK2, | |||
| $ RESULT( 15 ) ) | |||
| * | |||
| IF( ( ITRAN.EQ.1 .AND. M.GE.N ) .OR. | |||
+ 164
- 0
lapack-netlib/TESTING/LIN/zerrunhr_col.f
View File
| @@ -0,0 +1,164 @@ | |||
| *> \brief \b ZERRUNHR_COL | |||
| * | |||
| * =========== DOCUMENTATION =========== | |||
| * | |||
| * Online html documentation available at | |||
| * http://www.netlib.org/lapack/explore-html/ | |||
| * | |||
| * Definition: | |||
| * =========== | |||
| * | |||
| * SUBROUTINE ZERRUNHR_COL( PATH, NUNIT ) | |||
| * | |||
| * .. Scalar Arguments .. | |||
| * CHARACTER*3 PATH | |||
| * INTEGER NUNIT | |||
| * .. | |||
| * | |||
| * | |||
| *> \par Purpose: | |||
| * ============= | |||
| *> | |||
| *> \verbatim | |||
| *> | |||
| *> ZERRUNHR_COL tests the error exits for ZUNHR_COL that does | |||
| *> Householder reconstruction from the ouput of tall-skinny | |||
| *> factorization ZLATSQR. | |||
| *> \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 2019 | |||
| * | |||
| *> \ingroup complex16_lin | |||
| * | |||
| * ===================================================================== | |||
| SUBROUTINE ZERRUNHR_COL( PATH, NUNIT ) | |||
| IMPLICIT NONE | |||
| * | |||
| * -- LAPACK test routine (version 3.9.0) -- | |||
| * -- LAPACK is a software package provided by Univ. of Tennessee, -- | |||
| * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- | |||
| * November 2019 | |||
| * | |||
| * .. Scalar Arguments .. | |||
| CHARACTER(LEN=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 ), D(NMAX) | |||
| * .. | |||
| * .. External Subroutines .. | |||
| EXTERNAL ALAESM, CHKXER, ZUNHR_COL | |||
| * .. | |||
| * .. Scalars in Common .. | |||
| LOGICAL LERR, OK | |||
| CHARACTER(LEN=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 ) = DCMPLX( 1.D+0 / DBLE( I+J ) ) | |||
| T( I, J ) = DCMPLX( 1.D+0 / DBLE( I+J ) ) | |||
| END DO | |||
| D( J ) = ( 0.D+0, 0.D+0 ) | |||
| END DO | |||
| OK = .TRUE. | |||
| * | |||
| * Error exits for Householder reconstruction | |||
| * | |||
| * ZUNHR_COL | |||
| * | |||
| SRNAMT = 'ZUNHR_COL' | |||
| * | |||
| INFOT = 1 | |||
| CALL ZUNHR_COL( -1, 0, 1, A, 1, T, 1, D, INFO ) | |||
| CALL CHKXER( 'ZUNHR_COL', INFOT, NOUT, LERR, OK ) | |||
| * | |||
| INFOT = 2 | |||
| CALL ZUNHR_COL( 0, -1, 1, A, 1, T, 1, D, INFO ) | |||
| CALL CHKXER( 'ZUNHR_COL', INFOT, NOUT, LERR, OK ) | |||
| CALL ZUNHR_COL( 1, 2, 1, A, 1, T, 1, D, INFO ) | |||
| CALL CHKXER( 'ZUNHR_COL', INFOT, NOUT, LERR, OK ) | |||
| * | |||
| INFOT = 3 | |||
| CALL ZUNHR_COL( 0, 0, -1, A, 1, T, 1, D, INFO ) | |||
| CALL CHKXER( 'ZUNHR_COL', INFOT, NOUT, LERR, OK ) | |||
| * | |||
| CALL ZUNHR_COL( 0, 0, 0, A, 1, T, 1, D, INFO ) | |||
| CALL CHKXER( 'ZUNHR_COL', INFOT, NOUT, LERR, OK ) | |||
| * | |||
| INFOT = 5 | |||
| CALL ZUNHR_COL( 0, 0, 1, A, -1, T, 1, D, INFO ) | |||
| CALL CHKXER( 'ZUNHR_COL', INFOT, NOUT, LERR, OK ) | |||
| * | |||
| CALL ZUNHR_COL( 0, 0, 1, A, 0, T, 1, D, INFO ) | |||
| CALL CHKXER( 'ZUNHR_COL', INFOT, NOUT, LERR, OK ) | |||
| * | |||
| CALL ZUNHR_COL( 2, 0, 1, A, 1, T, 1, D, INFO ) | |||
| CALL CHKXER( 'ZUNHR_COL', INFOT, NOUT, LERR, OK ) | |||
| * | |||
| INFOT = 7 | |||
| CALL ZUNHR_COL( 0, 0, 1, A, 1, T, -1, D, INFO ) | |||
| CALL CHKXER( 'ZUNHR_COL', INFOT, NOUT, LERR, OK ) | |||
| * | |||
| CALL ZUNHR_COL( 0, 0, 1, A, 1, T, 0, D, INFO ) | |||
| CALL CHKXER( 'ZUNHR_COL', INFOT, NOUT, LERR, OK ) | |||
| * | |||
| CALL ZUNHR_COL( 4, 3, 2, A, 4, T, 1, D, INFO ) | |||
| CALL CHKXER( 'ZUNHR_COL', INFOT, NOUT, LERR, OK ) | |||
| * | |||
| * Print a summary line. | |||
| * | |||
| CALL ALAESM( PATH, OK, NOUT ) | |||
| * | |||
| RETURN | |||
| * | |||
| * End of ZERRUNHR_COL | |||
| * | |||
| END | |||
+ 33
- 3
lapack-netlib/TESTING/LIN/zerrvx.f
View File
| @@ -94,7 +94,7 @@ | |||
| $ ZHPSV, ZHPSVX, ZPBSV, ZPBSVX, ZPOSV, ZPOSVX, | |||
| $ ZPPSV, ZPPSVX, ZPTSV, ZPTSVX, ZSPSV, ZSPSVX, | |||
| $ ZSYSV, ZSYSV_AA, ZSYSV_RK, ZSYSV_ROOK, | |||
| $ ZSYSVX, ZSYSV_AA_2STAGE | |||
| $ ZSYSVX, ZHESV_AA_2STAGE | |||
| * .. | |||
| * .. Scalars in Common .. | |||
| LOGICAL LERR, OK | |||
| @@ -721,7 +721,7 @@ | |||
| * | |||
| ELSE IF( LSAMEN( 2, C2, 'H2' ) ) THEN | |||
| * | |||
| * CHESV_AASEN_2STAGE | |||
| * ZHESV_AASEN_2STAGE | |||
| * | |||
| SRNAMT = 'ZHESV_AA_2STAGE' | |||
| INFOT = 1 | |||
| @@ -741,7 +741,7 @@ | |||
| $ W, 1, INFO ) | |||
| CALL CHKXER( 'ZHESV_AA_2STAGE', INFOT, NOUT, LERR, OK ) | |||
| INFOT = 11 | |||
| CALL ZHESV_AA_2STAGE( 'U', 2, 1, A, 2, A, 2, IP, IP, B, 1, | |||
| CALL ZHESV_AA_2STAGE( 'U', 2, 1, A, 2, A, 8, IP, IP, B, 1, | |||
| $ W, 1, INFO ) | |||
| CALL CHKXER( 'ZHESV_AA_2STAGE', INFOT, NOUT, LERR, OK ) | |||
| INFOT = 7 | |||
| @@ -749,6 +749,36 @@ | |||
| $ W, 1, INFO ) | |||
| CALL CHKXER( 'ZHESV_AA_2STAGE', INFOT, NOUT, LERR, OK ) | |||
| * | |||
| ELSE IF( LSAMEN( 2, C2, 'S2' ) ) THEN | |||
| * | |||
| * ZSYSV_AASEN_2STAGE | |||
| * | |||
| SRNAMT = 'ZSYSV_AA_2STAGE' | |||
| INFOT = 1 | |||
| CALL ZSYSV_AA_2STAGE( '/', 0, 0, A, 1, A, 1, IP, IP, B, 1, | |||
| $ W, 1, INFO ) | |||
| CALL CHKXER( 'ZSYSV_AA_2STAGE', INFOT, NOUT, LERR, OK ) | |||
| INFOT = 2 | |||
| CALL ZSYSV_AA_2STAGE( 'U', -1, 0, A, 1, A, 1, IP, IP, B, 1, | |||
| $ W, 1, INFO ) | |||
| CALL CHKXER( 'ZSYSV_AA_2STAGE', INFOT, NOUT, LERR, OK ) | |||
| INFOT = 3 | |||
| CALL ZSYSV_AA_2STAGE( 'U', 0, -1, A, 1, A, 1, IP, IP, B, 1, | |||
| $ W, 1, INFO ) | |||
| CALL CHKXER( 'ZSYSV_AA_2STAGE', INFOT, NOUT, LERR, OK ) | |||
| INFOT = 5 | |||
| CALL ZSYSV_AA_2STAGE( 'U', 2, 1, A, 1, A, 1, IP, IP, B, 1, | |||
| $ W, 1, INFO ) | |||
| CALL CHKXER( 'ZSYSV_AA_2STAGE', INFOT, NOUT, LERR, OK ) | |||
| INFOT = 11 | |||
| CALL ZSYSV_AA_2STAGE( 'U', 2, 1, A, 2, A, 8, IP, IP, B, 1, | |||
| $ W, 1, INFO ) | |||
| CALL CHKXER( 'ZSYSV_AA_2STAGE', INFOT, NOUT, LERR, OK ) | |||
| INFOT = 7 | |||
| CALL ZSYSV_AA_2STAGE( 'U', 2, 1, A, 2, A, 1, IP, IP, B, 2, | |||
| $ W, 1, INFO ) | |||
| CALL CHKXER( 'ZSYSV_AA_2STAGE', INFOT, NOUT, LERR, OK ) | |||
| ** | |||
| ELSE IF( LSAMEN( 2, C2, 'HP' ) ) THEN | |||
| * | |||
| * ZHPSV | |||
+ 1
- 1
lapack-netlib/TESTING/LIN/zlahilb.f
View File
| @@ -164,7 +164,7 @@ | |||
| INTEGER NMAX_EXACT, NMAX_APPROX, SIZE_D | |||
| PARAMETER (NMAX_EXACT = 6, NMAX_APPROX = 11, SIZE_D = 8) | |||
| * | |||
| * d's are generated from random permuation of those eight elements. | |||
| * d's are generated from random permutation of those eight elements. | |||
| COMPLEX*16 d1(8), d2(8), invd1(8), invd2(8) | |||
| DATA D1 /(-1,0),(0,1),(-1,-1),(0,-1),(1,0),(-1,1),(1,1),(1,-1)/ | |||
| DATA D2 /(-1,0),(0,-1),(-1,1),(0,1),(1,0),(-1,-1),(1,-1),(1,1)/ | |||
+ 13
- 13
lapack-netlib/TESTING/LIN/ztsqr01.f
View File
| @@ -114,7 +114,7 @@ | |||
| * .. | |||
| * .. Local Arrays .. | |||
| INTEGER ISEED( 4 ) | |||
| COMPLEX*16 TQUERY( 5 ), WORKQUERY | |||
| COMPLEX*16 TQUERY( 5 ), WORKQUERY( 1 ) | |||
| * .. | |||
| * .. External Functions .. | |||
| DOUBLE PRECISION DLAMCH, ZLANGE, ZLANSY | |||
| @@ -173,22 +173,22 @@ | |||
| * | |||
| CALL ZGEQR( M, N, AF, M, TQUERY, -1, WORKQUERY, -1, INFO ) | |||
| TSIZE = INT( TQUERY( 1 ) ) | |||
| LWORK = INT( WORKQUERY ) | |||
| LWORK = INT( WORKQUERY( 1 ) ) | |||
| CALL ZGEMQR( 'L', 'N', M, M, K, AF, M, TQUERY, TSIZE, CF, M, | |||
| $ WORKQUERY, -1, INFO) | |||
| LWORK = MAX( LWORK, INT( WORKQUERY ) ) | |||
| LWORK = MAX( LWORK, INT( WORKQUERY( 1 ) ) ) | |||
| CALL ZGEMQR( 'L', 'N', M, N, K, AF, M, TQUERY, TSIZE, CF, M, | |||
| $ WORKQUERY, -1, INFO) | |||
| LWORK = MAX( LWORK, INT( WORKQUERY ) ) | |||
| LWORK = MAX( LWORK, INT( WORKQUERY( 1 ) ) ) | |||
| CALL ZGEMQR( 'L', 'C', M, N, K, AF, M, TQUERY, TSIZE, CF, M, | |||
| $ WORKQUERY, -1, INFO) | |||
| LWORK = MAX( LWORK, INT( WORKQUERY ) ) | |||
| LWORK = MAX( LWORK, INT( WORKQUERY( 1 ) ) ) | |||
| CALL ZGEMQR( 'R', 'N', N, M, K, AF, M, TQUERY, TSIZE, DF, N, | |||
| $ WORKQUERY, -1, INFO) | |||
| LWORK = MAX( LWORK, INT( WORKQUERY ) ) | |||
| LWORK = MAX( LWORK, INT( WORKQUERY( 1 ) ) ) | |||
| CALL ZGEMQR( 'R', 'C', N, M, K, AF, M, TQUERY, TSIZE, DF, N, | |||
| $ WORKQUERY, -1, INFO) | |||
| LWORK = MAX( LWORK, INT( WORKQUERY ) ) | |||
| LWORK = MAX( LWORK, INT( WORKQUERY( 1 ) ) ) | |||
| ALLOCATE ( T( TSIZE ) ) | |||
| ALLOCATE ( WORK( LWORK ) ) | |||
| srnamt = 'ZGEQR' | |||
| @@ -316,22 +316,22 @@ | |||
| ELSE | |||
| CALL ZGELQ( M, N, AF, M, TQUERY, -1, WORKQUERY, -1, INFO ) | |||
| TSIZE = INT( TQUERY( 1 ) ) | |||
| LWORK = INT( WORKQUERY ) | |||
| LWORK = INT( WORKQUERY( 1 ) ) | |||
| CALL ZGEMLQ( 'R', 'N', N, N, K, AF, M, TQUERY, TSIZE, Q, N, | |||
| $ WORKQUERY, -1, INFO ) | |||
| LWORK = MAX( LWORK, INT( WORKQUERY ) ) | |||
| LWORK = MAX( LWORK, INT( WORKQUERY( 1 ) ) ) | |||
| CALL ZGEMLQ( 'L', 'N', N, M, K, AF, M, TQUERY, TSIZE, DF, N, | |||
| $ WORKQUERY, -1, INFO) | |||
| LWORK = MAX( LWORK, INT( WORKQUERY ) ) | |||
| LWORK = MAX( LWORK, INT( WORKQUERY( 1 ) ) ) | |||
| CALL ZGEMLQ( 'L', 'C', N, M, K, AF, M, TQUERY, TSIZE, DF, N, | |||
| $ WORKQUERY, -1, INFO) | |||
| LWORK = MAX( LWORK, INT( WORKQUERY ) ) | |||
| LWORK = MAX( LWORK, INT( WORKQUERY( 1 ) ) ) | |||
| CALL ZGEMLQ( 'R', 'N', M, N, K, AF, M, TQUERY, TSIZE, CF, M, | |||
| $ WORKQUERY, -1, INFO) | |||
| LWORK = MAX( LWORK, INT( WORKQUERY ) ) | |||
| LWORK = MAX( LWORK, INT( WORKQUERY( 1 ) ) ) | |||
| CALL ZGEMLQ( 'R', 'C', M, N, K, AF, M, TQUERY, TSIZE, CF, M, | |||
| $ WORKQUERY, -1, INFO) | |||
| LWORK = MAX( LWORK, INT( WORKQUERY ) ) | |||
| LWORK = MAX( LWORK, INT( WORKQUERY( 1 ) ) ) | |||
| ALLOCATE ( T( TSIZE ) ) | |||
| ALLOCATE ( WORK( LWORK ) ) | |||
| srnamt = 'ZGELQ' | |||
+ 390
- 0
lapack-netlib/TESTING/LIN/zunhr_col01.f
View File
| @@ -0,0 +1,390 @@ | |||
| *> \brief \b ZUNHR_COL01 | |||
| * | |||
| * =========== DOCUMENTATION =========== | |||
| * | |||
| * Online html documentation available at | |||
| * http://www.netlib.org/lapack/explore-html/ | |||
| * | |||
| * Definition: | |||
| * =========== | |||
| * | |||
| * SUBROUTINE ZUNHR_COL01( M, N, MB1, NB1, NB2, RESULT ) | |||
| * | |||
| * .. Scalar Arguments .. | |||
| * INTEGER M, N, MB1, NB1, NB2 | |||
| * .. Return values .. | |||
| * DOUBLE PRECISION RESULT(6) | |||
| * | |||
| * | |||
| *> \par Purpose: | |||
| * ============= | |||
| *> | |||
| *> \verbatim | |||
| *> | |||
| *> ZUNHR_COL01 tests ZUNHR_COL using ZLATSQR, ZGEMQRT and ZUNGTSQR. | |||
| *> Therefore, ZLATSQR (part of ZGEQR), ZGEMQRT (part ZGEMQR), ZUNGTSQR | |||
| *> have to be tested before this test. | |||
| *> | |||
| *> \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] MB1 | |||
| *> \verbatim | |||
| *> MB1 is INTEGER | |||
| *> Number of row in row block in an input test matrix. | |||
| *> \endverbatim | |||
| *> | |||
| *> \param[in] NB1 | |||
| *> \verbatim | |||
| *> NB1 is INTEGER | |||
| *> Number of columns in column block an input test matrix. | |||
| *> \endverbatim | |||
| *> | |||
| *> \param[in] NB2 | |||
| *> \verbatim | |||
| *> NB2 is INTEGER | |||
| *> Number of columns in column block in an output test matrix. | |||
| *> \endverbatim | |||
| *> | |||
| *> \param[out] RESULT | |||
| *> \verbatim | |||
| *> RESULT is DOUBLE PRECISION array, dimension (6) | |||
| *> Results of each of the six tests below. | |||
| *> ( C is a M-by-N random matrix, D is a N-by-M random matrix ) | |||
| *> | |||
| *> RESULT(1) = | A - Q * R | / (eps * m * |A|) | |||
| *> RESULT(2) = | I - (Q**H) * Q | / (eps * m ) | |||
| *> RESULT(3) = | Q * C - Q * C | / (eps * m * |C|) | |||
| *> RESULT(4) = | (Q**H) * C - (Q**H) * C | / (eps * m * |C|) | |||
| *> RESULT(5) = | (D * Q) - D * Q | / (eps * m * |D|) | |||
| *> RESULT(6) = | D * (Q**H) - D * (Q**H) | / (eps * m * |D|) | |||
| *> \endverbatim | |||
| * | |||
| * Authors: | |||
| * ======== | |||
| * | |||
| *> \author Univ. of Tennessee | |||
| *> \author Univ. of California Berkeley | |||
| *> \author Univ. of Colorado Denver | |||
| *> \author NAG Ltd. | |||
| * | |||
| *> \date November 2019 | |||
| * | |||
| *> \ingroup complex16_lin | |||
| * | |||
| * ===================================================================== | |||
| SUBROUTINE ZUNHR_COL01( M, N, MB1, NB1, NB2, RESULT ) | |||
| IMPLICIT NONE | |||
| * | |||
| * -- LAPACK test routine (version 3.9.0) -- | |||
| * -- LAPACK is a software package provided by Univ. of Tennessee, -- | |||
| * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- | |||
| * November 2019 | |||
| * | |||
| * .. Scalar Arguments .. | |||
| INTEGER M, N, MB1, NB1, NB2 | |||
| * .. Return values .. | |||
| DOUBLE PRECISION RESULT(6) | |||
| * | |||
| * ===================================================================== | |||
| * | |||
| * .. | |||
| * .. Local allocatable arrays | |||
| COMPLEX*16, ALLOCATABLE :: A(:,:), AF(:,:), Q(:,:), R(:,:), | |||
| $ WORK( : ), T1(:,:), T2(:,:), DIAG(:), | |||
| $ C(:,:), CF(:,:), D(:,:), DF(:,:) | |||
| DOUBLE PRECISION, ALLOCATABLE :: RWORK(:) | |||
| * | |||
| * .. Parameters .. | |||
| DOUBLE PRECISION ZERO | |||
| PARAMETER ( ZERO = 0.0D+0 ) | |||
| COMPLEX*16 CONE, CZERO | |||
| PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ), | |||
| $ CZERO = ( 0.0D+0, 0.0D+0 ) ) | |||
| * .. | |||
| * .. Local Scalars .. | |||
| LOGICAL TESTZEROS | |||
| INTEGER INFO, I, J, K, L, LWORK, NB1_UB, NB2_UB, NRB | |||
| DOUBLE PRECISION ANORM, EPS, RESID, CNORM, DNORM | |||
| * .. | |||
| * .. Local Arrays .. | |||
| INTEGER ISEED( 4 ) | |||
| COMPLEX*16 WORKQUERY( 1 ) | |||
| * .. | |||
| * .. External Functions .. | |||
| DOUBLE PRECISION DLAMCH, ZLANGE, ZLANSY | |||
| EXTERNAL DLAMCH, ZLANGE, ZLANSY | |||
| * .. | |||
| * .. External Subroutines .. | |||
| EXTERNAL ZLACPY, ZLARNV, ZLASET, ZLATSQR, ZUNHR_COL, | |||
| $ ZUNGTSQR, ZSCAL, ZGEMM, ZGEMQRT, ZHERK | |||
| * .. | |||
| * .. Intrinsic Functions .. | |||
| INTRINSIC CEILING, DBLE, MAX, MIN | |||
| * .. | |||
| * .. Scalars in Common .. | |||
| CHARACTER(LEN=32) SRNAMT | |||
| * .. | |||
| * .. Common blocks .. | |||
| COMMON / SRMNAMC / SRNAMT | |||
| * .. | |||
| * .. Data statements .. | |||
| DATA ISEED / 1988, 1989, 1990, 1991 / | |||
| * | |||
| * TEST MATRICES WITH HALF OF MATRIX BEING ZEROS | |||
| * | |||
| TESTZEROS = .FALSE. | |||
| * | |||
| EPS = DLAMCH( 'Epsilon' ) | |||
| K = MIN( M, N ) | |||
| L = MAX( M, N, 1) | |||
| * | |||
| * Dynamically allocate local arrays | |||
| * | |||
| ALLOCATE ( A(M,N), AF(M,N), Q(L,L), R(M,L), RWORK(L), | |||
| $ C(M,N), CF(M,N), | |||
| $ D(N,M), DF(N,M) ) | |||
| * | |||
| * 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 ) | |||
| * | |||
| * Number of row blocks in ZLATSQR | |||
| * | |||
| NRB = MAX( 1, CEILING( DBLE( M - N ) / DBLE( MB1 - N ) ) ) | |||
| * | |||
| ALLOCATE ( T1( NB1, N * NRB ) ) | |||
| ALLOCATE ( T2( NB2, N ) ) | |||
| ALLOCATE ( DIAG( N ) ) | |||
| * | |||
| * Begin determine LWORK for the array WORK and allocate memory. | |||
| * | |||
| * ZLATSQR requires NB1 to be bounded by N. | |||
| * | |||
| NB1_UB = MIN( NB1, N) | |||
| * | |||
| * ZGEMQRT requires NB2 to be bounded by N. | |||
| * | |||
| NB2_UB = MIN( NB2, N) | |||
| * | |||
| CALL ZLATSQR( M, N, MB1, NB1_UB, AF, M, T1, NB1, | |||
| $ WORKQUERY, -1, INFO ) | |||
| LWORK = INT( WORKQUERY( 1 ) ) | |||
| CALL ZUNGTSQR( M, N, MB1, NB1, AF, M, T1, NB1, WORKQUERY, -1, | |||
| $ INFO ) | |||
| LWORK = MAX( LWORK, INT( WORKQUERY( 1 ) ) ) | |||
| * | |||
| * In ZGEMQRT, WORK is N*NB2_UB if SIDE = 'L', | |||
| * or M*NB2_UB if SIDE = 'R'. | |||
| * | |||
| LWORK = MAX( LWORK, NB2_UB * N, NB2_UB * M ) | |||
| * | |||
| ALLOCATE ( WORK( LWORK ) ) | |||
| * | |||
| * End allocate memory for WORK. | |||
| * | |||
| * | |||
| * Begin Householder reconstruction routines | |||
| * | |||
| * Factor the matrix A in the array AF. | |||
| * | |||
| SRNAMT = 'ZLATSQR' | |||
| CALL ZLATSQR( M, N, MB1, NB1_UB, AF, M, T1, NB1, WORK, LWORK, | |||
| $ INFO ) | |||
| * | |||
| * Copy the factor R into the array R. | |||
| * | |||
| SRNAMT = 'ZLACPY' | |||
| CALL ZLACPY( 'U', M, N, AF, M, R, M ) | |||
| * | |||
| * Reconstruct the orthogonal matrix Q. | |||
| * | |||
| SRNAMT = 'ZUNGTSQR' | |||
| CALL ZUNGTSQR( M, N, MB1, NB1, AF, M, T1, NB1, WORK, LWORK, | |||
| $ INFO ) | |||
| * | |||
| * Perform the Householder reconstruction, the result is stored | |||
| * the arrays AF and T2. | |||
| * | |||
| SRNAMT = 'ZUNHR_COL' | |||
| CALL ZUNHR_COL( M, N, NB2, AF, M, T2, NB2, DIAG, INFO ) | |||
| * | |||
| * Compute the factor R_hr corresponding to the Householder | |||
| * reconstructed Q_hr and place it in the upper triangle of AF to | |||
| * match the Q storage format in ZGEQRT. R_hr = R_tsqr * S, | |||
| * this means changing the sign of I-th row of the matrix R_tsqr | |||
| * according to sign of of I-th diagonal element DIAG(I) of the | |||
| * matrix S. | |||
| * | |||
| SRNAMT = 'ZLACPY' | |||
| CALL ZLACPY( 'U', M, N, R, M, AF, M ) | |||
| * | |||
| DO I = 1, N | |||
| IF( DIAG( I ).EQ.-CONE ) THEN | |||
| CALL ZSCAL( N+1-I, -CONE, AF( I, I ), M ) | |||
| END IF | |||
| END DO | |||
| * | |||
| * End Householder reconstruction routines. | |||
| * | |||
| * | |||
| * Generate the m-by-m matrix Q | |||
| * | |||
| CALL ZLASET( 'Full', M, M, CZERO, CONE, Q, M ) | |||
| * | |||
| SRNAMT = 'ZGEMQRT' | |||
| CALL ZGEMQRT( 'L', 'N', M, M, K, NB2_UB, AF, M, T2, NB2, Q, M, | |||
| $ WORK, INFO ) | |||
| * | |||
| * Copy R | |||
| * | |||
| CALL ZLASET( 'Full', M, N, CZERO, CZERO, R, M ) | |||
| * | |||
| CALL ZLACPY( 'Upper', M, N, AF, M, R, M ) | |||
| * | |||
| * TEST 1 | |||
| * Compute |R - (Q**H)*A| / ( eps * m * |A| ) and store in RESULT(1) | |||
| * | |||
| CALL ZGEMM( 'C', 'N', M, N, M, -CONE, Q, M, A, M, CONE, 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 | |||
| * | |||
| * TEST 2 | |||
| * Compute |I - (Q**H)*Q| / ( eps * m ) and store in RESULT(2) | |||
| * | |||
| CALL ZLASET( 'Full', M, M, CZERO, CONE, R, M ) | |||
| CALL ZHERK( 'U', 'C', M, M, -CONE, Q, M, CONE, R, M ) | |||
| RESID = ZLANSY( '1', 'Upper', M, R, M, RWORK ) | |||
| RESULT( 2 ) = RESID / ( EPS * MAX( 1, M ) ) | |||
| * | |||
| * Generate random m-by-n matrix C | |||
| * | |||
| 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 = CF | |||
| * | |||
| SRNAMT = 'ZGEMQRT' | |||
| CALL ZGEMQRT( 'L', 'N', M, N, K, NB2_UB, AF, M, T2, NB2, CF, M, | |||
| $ WORK, INFO ) | |||
| * | |||
| * TEST 3 | |||
| * Compute |CF - Q*C| / ( eps * m * |C| ) | |||
| * | |||
| CALL ZGEMM( 'N', 'N', M, N, M, -CONE, Q, M, C, M, CONE, 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 (Q**H)*C = CF | |||
| * | |||
| SRNAMT = 'ZGEMQRT' | |||
| CALL ZGEMQRT( 'L', 'C', M, N, K, NB2_UB, AF, M, T2, NB2, CF, M, | |||
| $ WORK, INFO ) | |||
| * | |||
| * TEST 4 | |||
| * Compute |CF - (Q**H)*C| / ( eps * m * |C|) | |||
| * | |||
| CALL ZGEMM( 'C', 'N', M, N, M, -CONE, Q, M, C, M, CONE, 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 = DF | |||
| * | |||
| SRNAMT = 'ZGEMQRT' | |||
| CALL ZGEMQRT( 'R', 'N', N, M, K, NB2_UB, AF, M, T2, NB2, DF, N, | |||
| $ WORK, INFO ) | |||
| * | |||
| * TEST 5 | |||
| * Compute |DF - D*Q| / ( eps * m * |D| ) | |||
| * | |||
| CALL ZGEMM( 'N', 'N', N, M, M, -CONE, D, N, Q, M, CONE, 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 = DF | |||
| * | |||
| SRNAMT = 'ZGEMQRT' | |||
| CALL ZGEMQRT( 'R', 'C', N, M, K, NB2_UB, AF, M, T2, NB2, DF, N, | |||
| $ WORK, INFO ) | |||
| * | |||
| * TEST 6 | |||
| * Compute |DF - D*(Q**H)| / ( eps * m * |D| ) | |||
| * | |||
| CALL ZGEMM( 'N', 'C', N, M, M, -CONE, D, N, Q, M, CONE, DF, N ) | |||
| RESID = ZLANGE( '1', N, M, DF, N, RWORK ) | |||
| IF( DNORM.GT.ZERO ) THEN | |||
| RESULT( 6 ) = RESID / ( EPS * MAX( 1, M ) * DNORM ) | |||
| ELSE | |||
| RESULT( 6 ) = ZERO | |||
| END IF | |||
| * | |||
| * Deallocate all arrays | |||
| * | |||
| DEALLOCATE ( A, AF, Q, R, RWORK, WORK, T1, T2, DIAG, | |||
| $ C, D, CF, DF ) | |||
| * | |||
| RETURN | |||
| * | |||
| * End of ZUNHR_COL01 | |||
| * | |||
| END | |||