From ab74361a0c583a0755d809a23d206f16c9717f6c Mon Sep 17 00:00:00 2001 From: Martin Kroeker Date: Mon, 30 Dec 2019 16:23:25 +0100 Subject: [PATCH] Update LAPACK to 3.9.0 --- lapack-netlib/TESTING/LIN/CMakeLists.txt | 12 +- lapack-netlib/TESTING/LIN/Makefile | 75 ++--- lapack-netlib/TESTING/LIN/cchkaa.f | 40 ++- lapack-netlib/TESTING/LIN/cchkunhr_col.f | 239 ++++++++++++++ lapack-netlib/TESTING/LIN/cdrvls.f | 25 +- lapack-netlib/TESTING/LIN/cdrvsy_rk.f | 3 +- lapack-netlib/TESTING/LIN/cerrunhr_col.f | 164 ++++++++++ lapack-netlib/TESTING/LIN/cerrvx.f | 4 +- lapack-netlib/TESTING/LIN/clahilb.f | 2 +- lapack-netlib/TESTING/LIN/ctsqr01.f | 26 +- lapack-netlib/TESTING/LIN/cunhr_col01.f | 390 +++++++++++++++++++++++ lapack-netlib/TESTING/LIN/dchkaa.f | 39 ++- lapack-netlib/TESTING/LIN/dchkorhr_col.f | 239 ++++++++++++++ lapack-netlib/TESTING/LIN/ddrvls.f | 16 +- lapack-netlib/TESTING/LIN/derrorhr_col.f | 164 ++++++++++ lapack-netlib/TESTING/LIN/derrvx.f | 2 +- lapack-netlib/TESTING/LIN/dorhr_col01.f | 386 ++++++++++++++++++++++ lapack-netlib/TESTING/LIN/dtsqr01.f | 26 +- lapack-netlib/TESTING/LIN/schkaa.f | 35 +- lapack-netlib/TESTING/LIN/schkorhr_col.f | 239 ++++++++++++++ lapack-netlib/TESTING/LIN/sdrvls.f | 20 +- lapack-netlib/TESTING/LIN/serrorhr_col.f | 164 ++++++++++ lapack-netlib/TESTING/LIN/serrvx.f | 2 +- lapack-netlib/TESTING/LIN/sorhr_col01.f | 386 ++++++++++++++++++++++ lapack-netlib/TESTING/LIN/stsqr01.f | 26 +- lapack-netlib/TESTING/LIN/zchkaa.f | 43 ++- lapack-netlib/TESTING/LIN/zchkunhr_col.f | 239 ++++++++++++++ lapack-netlib/TESTING/LIN/zdrvhe_rk.f | 1 + lapack-netlib/TESTING/LIN/zdrvls.f | 25 +- lapack-netlib/TESTING/LIN/zerrunhr_col.f | 164 ++++++++++ lapack-netlib/TESTING/LIN/zerrvx.f | 36 ++- lapack-netlib/TESTING/LIN/zlahilb.f | 2 +- lapack-netlib/TESTING/LIN/ztsqr01.f | 26 +- lapack-netlib/TESTING/LIN/zunhr_col01.f | 390 +++++++++++++++++++++++ 34 files changed, 3454 insertions(+), 196 deletions(-) create mode 100644 lapack-netlib/TESTING/LIN/cchkunhr_col.f create mode 100644 lapack-netlib/TESTING/LIN/cerrunhr_col.f create mode 100644 lapack-netlib/TESTING/LIN/cunhr_col01.f create mode 100644 lapack-netlib/TESTING/LIN/dchkorhr_col.f create mode 100644 lapack-netlib/TESTING/LIN/derrorhr_col.f create mode 100644 lapack-netlib/TESTING/LIN/dorhr_col01.f create mode 100644 lapack-netlib/TESTING/LIN/schkorhr_col.f create mode 100644 lapack-netlib/TESTING/LIN/serrorhr_col.f create mode 100644 lapack-netlib/TESTING/LIN/sorhr_col01.f create mode 100644 lapack-netlib/TESTING/LIN/zchkunhr_col.f create mode 100644 lapack-netlib/TESTING/LIN/zerrunhr_col.f create mode 100644 lapack-netlib/TESTING/LIN/zunhr_col01.f diff --git a/lapack-netlib/TESTING/LIN/CMakeLists.txt b/lapack-netlib/TESTING/LIN/CMakeLists.txt index 50ba8fc28..c941d3577 100644 --- a/lapack-netlib/TESTING/LIN/CMakeLists.txt +++ b/lapack-netlib/TESTING/LIN/CMakeLists.txt @@ -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 diff --git a/lapack-netlib/TESTING/LIN/Makefile b/lapack-netlib/TESTING/LIN/Makefile index 1a332f70b..e86b9e0c9 100644 --- a/lapack-netlib/TESTING/LIN/Makefile +++ b/lapack-netlib/TESTING/LIN/Makefile @@ -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: diff --git a/lapack-netlib/TESTING/LIN/cchkaa.f b/lapack-netlib/TESTING/LIN/cchkaa.f index d8d5060c3..d36770be7 100644 --- a/lapack-netlib/TESTING/LIN/cchkaa.f +++ b/lapack-netlib/TESTING/LIN/cchkaa.f @@ -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 * diff --git a/lapack-netlib/TESTING/LIN/cchkunhr_col.f b/lapack-netlib/TESTING/LIN/cchkunhr_col.f new file mode 100644 index 000000000..00077ddd9 --- /dev/null +++ b/lapack-netlib/TESTING/LIN/cchkunhr_col.f @@ -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 \ No newline at end of file diff --git a/lapack-netlib/TESTING/LIN/cdrvls.f b/lapack-netlib/TESTING/LIN/cdrvls.f index 2c2d9abb8..d24e3885b 100644 --- a/lapack-netlib/TESTING/LIN/cdrvls.f +++ b/lapack-netlib/TESTING/LIN/cdrvls.f @@ -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. diff --git a/lapack-netlib/TESTING/LIN/cdrvsy_rk.f b/lapack-netlib/TESTING/LIN/cdrvsy_rk.f index ae313c243..d3ed8c0a9 100644 --- a/lapack-netlib/TESTING/LIN/cdrvsy_rk.f +++ b/lapack-netlib/TESTING/LIN/cdrvsy_rk.f @@ -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 diff --git a/lapack-netlib/TESTING/LIN/cerrunhr_col.f b/lapack-netlib/TESTING/LIN/cerrunhr_col.f new file mode 100644 index 000000000..8fd58a683 --- /dev/null +++ b/lapack-netlib/TESTING/LIN/cerrunhr_col.f @@ -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 diff --git a/lapack-netlib/TESTING/LIN/cerrvx.f b/lapack-netlib/TESTING/LIN/cerrvx.f index d2d3d2a85..7f929f07f 100644 --- a/lapack-netlib/TESTING/LIN/cerrvx.f +++ b/lapack-netlib/TESTING/LIN/cerrvx.f @@ -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 diff --git a/lapack-netlib/TESTING/LIN/clahilb.f b/lapack-netlib/TESTING/LIN/clahilb.f index f88491a0d..c54884b9f 100644 --- a/lapack-netlib/TESTING/LIN/clahilb.f +++ b/lapack-netlib/TESTING/LIN/clahilb.f @@ -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)/ diff --git a/lapack-netlib/TESTING/LIN/ctsqr01.f b/lapack-netlib/TESTING/LIN/ctsqr01.f index a3bd9ebc9..6d788ba41 100644 --- a/lapack-netlib/TESTING/LIN/ctsqr01.f +++ b/lapack-netlib/TESTING/LIN/ctsqr01.f @@ -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' diff --git a/lapack-netlib/TESTING/LIN/cunhr_col01.f b/lapack-netlib/TESTING/LIN/cunhr_col01.f new file mode 100644 index 000000000..d760caba5 --- /dev/null +++ b/lapack-netlib/TESTING/LIN/cunhr_col01.f @@ -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 diff --git a/lapack-netlib/TESTING/LIN/dchkaa.f b/lapack-netlib/TESTING/LIN/dchkaa.f index c5fd7afda..03575c4d1 100644 --- a/lapack-netlib/TESTING/LIN/dchkaa.f +++ b/lapack-netlib/TESTING/LIN/dchkaa.f @@ -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 diff --git a/lapack-netlib/TESTING/LIN/dchkorhr_col.f b/lapack-netlib/TESTING/LIN/dchkorhr_col.f new file mode 100644 index 000000000..3b3e421eb --- /dev/null +++ b/lapack-netlib/TESTING/LIN/dchkorhr_col.f @@ -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 \ No newline at end of file diff --git a/lapack-netlib/TESTING/LIN/ddrvls.f b/lapack-netlib/TESTING/LIN/ddrvls.f index 2f4975553..adfd71e09 100644 --- a/lapack-netlib/TESTING/LIN/ddrvls.f +++ b/lapack-netlib/TESTING/LIN/ddrvls.f @@ -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, diff --git a/lapack-netlib/TESTING/LIN/derrorhr_col.f b/lapack-netlib/TESTING/LIN/derrorhr_col.f new file mode 100644 index 000000000..6d545bc91 --- /dev/null +++ b/lapack-netlib/TESTING/LIN/derrorhr_col.f @@ -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 diff --git a/lapack-netlib/TESTING/LIN/derrvx.f b/lapack-netlib/TESTING/LIN/derrvx.f index 3a4a6b7fc..fd1d038a6 100644 --- a/lapack-netlib/TESTING/LIN/derrvx.f +++ b/lapack-netlib/TESTING/LIN/derrvx.f @@ -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 diff --git a/lapack-netlib/TESTING/LIN/dorhr_col01.f b/lapack-netlib/TESTING/LIN/dorhr_col01.f new file mode 100644 index 000000000..3e48de37f --- /dev/null +++ b/lapack-netlib/TESTING/LIN/dorhr_col01.f @@ -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 diff --git a/lapack-netlib/TESTING/LIN/dtsqr01.f b/lapack-netlib/TESTING/LIN/dtsqr01.f index 7a50009cc..25bf58a81 100644 --- a/lapack-netlib/TESTING/LIN/dtsqr01.f +++ b/lapack-netlib/TESTING/LIN/dtsqr01.f @@ -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' diff --git a/lapack-netlib/TESTING/LIN/schkaa.f b/lapack-netlib/TESTING/LIN/schkaa.f index 33b109aa7..a9c13e442 100644 --- a/lapack-netlib/TESTING/LIN/schkaa.f +++ b/lapack-netlib/TESTING/LIN/schkaa.f @@ -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 * diff --git a/lapack-netlib/TESTING/LIN/schkorhr_col.f b/lapack-netlib/TESTING/LIN/schkorhr_col.f new file mode 100644 index 000000000..cf6d2d323 --- /dev/null +++ b/lapack-netlib/TESTING/LIN/schkorhr_col.f @@ -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 \ No newline at end of file diff --git a/lapack-netlib/TESTING/LIN/sdrvls.f b/lapack-netlib/TESTING/LIN/sdrvls.f index 2cf3439b5..649ca558c 100644 --- a/lapack-netlib/TESTING/LIN/sdrvls.f +++ b/lapack-netlib/TESTING/LIN/sdrvls.f @@ -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, diff --git a/lapack-netlib/TESTING/LIN/serrorhr_col.f b/lapack-netlib/TESTING/LIN/serrorhr_col.f new file mode 100644 index 000000000..e8d81a99c --- /dev/null +++ b/lapack-netlib/TESTING/LIN/serrorhr_col.f @@ -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 diff --git a/lapack-netlib/TESTING/LIN/serrvx.f b/lapack-netlib/TESTING/LIN/serrvx.f index a63ed38d7..910bff1e5 100644 --- a/lapack-netlib/TESTING/LIN/serrvx.f +++ b/lapack-netlib/TESTING/LIN/serrvx.f @@ -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 diff --git a/lapack-netlib/TESTING/LIN/sorhr_col01.f b/lapack-netlib/TESTING/LIN/sorhr_col01.f new file mode 100644 index 000000000..02429041b --- /dev/null +++ b/lapack-netlib/TESTING/LIN/sorhr_col01.f @@ -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 diff --git a/lapack-netlib/TESTING/LIN/stsqr01.f b/lapack-netlib/TESTING/LIN/stsqr01.f index b661d61f4..8eb69eae7 100644 --- a/lapack-netlib/TESTING/LIN/stsqr01.f +++ b/lapack-netlib/TESTING/LIN/stsqr01.f @@ -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' diff --git a/lapack-netlib/TESTING/LIN/zchkaa.f b/lapack-netlib/TESTING/LIN/zchkaa.f index d2be2525d..30d2a084a 100644 --- a/lapack-netlib/TESTING/LIN/zchkaa.f +++ b/lapack-netlib/TESTING/LIN/zchkaa.f @@ -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 * diff --git a/lapack-netlib/TESTING/LIN/zchkunhr_col.f b/lapack-netlib/TESTING/LIN/zchkunhr_col.f new file mode 100644 index 000000000..ef8f8bcc4 --- /dev/null +++ b/lapack-netlib/TESTING/LIN/zchkunhr_col.f @@ -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 \ No newline at end of file diff --git a/lapack-netlib/TESTING/LIN/zdrvhe_rk.f b/lapack-netlib/TESTING/LIN/zdrvhe_rk.f index 93c3fe61d..355260aad 100644 --- a/lapack-netlib/TESTING/LIN/zdrvhe_rk.f +++ b/lapack-netlib/TESTING/LIN/zdrvhe_rk.f @@ -98,6 +98,7 @@ *> \param[out] E *> \verbatim *> E is COMPLEX*16 array, dimension (NMAX) +*> \endverbatim *> *> \param[out] AINV *> \verbatim diff --git a/lapack-netlib/TESTING/LIN/zdrvls.f b/lapack-netlib/TESTING/LIN/zdrvls.f index 681852bc2..4587c5686 100644 --- a/lapack-netlib/TESTING/LIN/zdrvls.f +++ b/lapack-netlib/TESTING/LIN/zdrvls.f @@ -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. diff --git a/lapack-netlib/TESTING/LIN/zerrunhr_col.f b/lapack-netlib/TESTING/LIN/zerrunhr_col.f new file mode 100644 index 000000000..4fb62734d --- /dev/null +++ b/lapack-netlib/TESTING/LIN/zerrunhr_col.f @@ -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 diff --git a/lapack-netlib/TESTING/LIN/zerrvx.f b/lapack-netlib/TESTING/LIN/zerrvx.f index 29ba744ed..7759384e6 100644 --- a/lapack-netlib/TESTING/LIN/zerrvx.f +++ b/lapack-netlib/TESTING/LIN/zerrvx.f @@ -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 diff --git a/lapack-netlib/TESTING/LIN/zlahilb.f b/lapack-netlib/TESTING/LIN/zlahilb.f index a6dc79b20..ba83af825 100644 --- a/lapack-netlib/TESTING/LIN/zlahilb.f +++ b/lapack-netlib/TESTING/LIN/zlahilb.f @@ -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)/ diff --git a/lapack-netlib/TESTING/LIN/ztsqr01.f b/lapack-netlib/TESTING/LIN/ztsqr01.f index 094473888..81d7fdb44 100644 --- a/lapack-netlib/TESTING/LIN/ztsqr01.f +++ b/lapack-netlib/TESTING/LIN/ztsqr01.f @@ -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' diff --git a/lapack-netlib/TESTING/LIN/zunhr_col01.f b/lapack-netlib/TESTING/LIN/zunhr_col01.f new file mode 100644 index 000000000..9fb3bf352 --- /dev/null +++ b/lapack-netlib/TESTING/LIN/zunhr_col01.f @@ -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