Update LAPACK to 3.9.0
This commit is contained in:
Martin Kroeker
GitHub
parent
4f0b98d46d
commit
ab74361a0c
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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:
|
||||
|
|
|
|||
|
|
@ -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
|
||||
*
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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.
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)/
|
||||
|
|
|
|||
|
|
@ -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'
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -1008,7 +1011,19 @@
|
|||
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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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,
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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'
|
||||
|
|
|
|||
|
|
@ -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
|
||||
*
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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,
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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'
|
||||
|
|
|
|||
|
|
@ -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
|
||||
*
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -98,6 +98,7 @@
|
|||
*> \param[out] E
|
||||
*> \verbatim
|
||||
*> E is COMPLEX*16 array, dimension (NMAX)
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] AINV
|
||||
*> \verbatim
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)/
|
||||
|
|
|
|||
|
|
@ -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'
|
||||
|
|
|
|||
|
|
@ -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
|
||||
Loading…
Reference in New Issue