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
|
strt02.f strt03.f strt05.f strt06.f
|
||||||
sgennd.f sqrt04.f sqrt05.f schkqrt.f serrqrt.f schkqrtp.f serrqrtp.f
|
sgennd.f sqrt04.f sqrt05.f schkqrt.f serrqrt.f schkqrtp.f serrqrtp.f
|
||||||
schklqt.f schklqtp.f schktsqr.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)
|
if(USE_XBLAS)
|
||||||
list(APPEND SLINTST sdrvgbx.f sdrvgex.f sdrvsyx.f sdrvpox.f
|
list(APPEND SLINTST sdrvgbx.f sdrvgex.f sdrvsyx.f sdrvpox.f
|
||||||
|
|
@ -94,7 +95,8 @@ set(CLINTST cchkaa.f
|
||||||
sget06.f cgennd.f
|
sget06.f cgennd.f
|
||||||
cqrt04.f cqrt05.f cchkqrt.f cerrqrt.f cchkqrtp.f cerrqrtp.f
|
cqrt04.f cqrt05.f cchkqrt.f cerrqrt.f cchkqrtp.f cerrqrtp.f
|
||||||
cchklqt.f cchklqtp.f cchktsqr.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)
|
if(USE_XBLAS)
|
||||||
list(APPEND CLINTST cdrvgbx.f cdrvgex.f cdrvhex.f cdrvsyx.f cdrvpox.f
|
list(APPEND CLINTST cdrvgbx.f cdrvgex.f cdrvhex.f cdrvsyx.f cdrvpox.f
|
||||||
|
|
@ -139,7 +141,8 @@ set(DLINTST dchkaa.f
|
||||||
dgennd.f
|
dgennd.f
|
||||||
dqrt04.f dqrt05.f dchkqrt.f derrqrt.f dchkqrtp.f derrqrtp.f
|
dqrt04.f dqrt05.f dchkqrt.f derrqrt.f dchkqrtp.f derrqrtp.f
|
||||||
dchklq.f dchklqt.f dchklqtp.f dchktsqr.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)
|
if(USE_XBLAS)
|
||||||
list(APPEND DLINTST ddrvgbx.f ddrvgex.f ddrvsyx.f ddrvpox.f
|
list(APPEND DLINTST ddrvgbx.f ddrvgex.f ddrvsyx.f ddrvpox.f
|
||||||
|
|
@ -194,7 +197,8 @@ set(ZLINTST zchkaa.f
|
||||||
dget06.f zgennd.f
|
dget06.f zgennd.f
|
||||||
zqrt04.f zqrt05.f zchkqrt.f zerrqrt.f zchkqrtp.f zerrqrtp.f
|
zqrt04.f zqrt05.f zchkqrt.f zerrqrt.f zchkqrtp.f zerrqrtp.f
|
||||||
zchklqt.f zchklqtp.f zchktsqr.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)
|
if(USE_XBLAS)
|
||||||
list(APPEND ZLINTST zdrvgbx.f zdrvgex.f zdrvhex.f zdrvsyx.f zdrvpox.f
|
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
|
# This makefile creates the test programs for the linear equation
|
||||||
# routines in LAPACK. The test files are grouped as follows:
|
# routines in LAPACK. The test files are grouped as follows:
|
||||||
|
|
@ -33,10 +31,8 @@ include ../../make.inc
|
||||||
#
|
#
|
||||||
#######################################################################
|
#######################################################################
|
||||||
|
|
||||||
ifneq ($(strip $(VARLIB)),)
|
TOPSRCDIR = ../..
|
||||||
LAPACKLIB := $(VARLIB) ../../$(LAPACKLIB)
|
include $(TOPSRCDIR)/make.inc
|
||||||
endif
|
|
||||||
|
|
||||||
|
|
||||||
ALINTST = \
|
ALINTST = \
|
||||||
aladhd.o alaerh.o alaesm.o alahd.o alareq.o \
|
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 \
|
strt02.o strt03.o strt05.o strt06.o \
|
||||||
sgennd.o sqrt04.o sqrt05.o schkqrt.o serrqrt.o schkqrtp.o serrqrtp.o \
|
sgennd.o sqrt04.o sqrt05.o schkqrt.o serrqrt.o schkqrtp.o serrqrtp.o \
|
||||||
schklqt.o schklqtp.o schktsqr.o \
|
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
|
ifdef USEXBLAS
|
||||||
SLINTST += sdrvgbx.o sdrvgex.o sdrvsyx.o sdrvpox.o \
|
SLINTST += sdrvgbx.o sdrvgex.o sdrvsyx.o sdrvpox.o \
|
||||||
|
|
@ -125,7 +122,8 @@ CLINTST = cchkaa.o \
|
||||||
sget06.o cgennd.o \
|
sget06.o cgennd.o \
|
||||||
cqrt04.o cqrt05.o cchkqrt.o cerrqrt.o cchkqrtp.o cerrqrtp.o \
|
cqrt04.o cqrt05.o cchkqrt.o cerrqrt.o cchkqrtp.o cerrqrtp.o \
|
||||||
cchklqt.o cchklqtp.o cchktsqr.o \
|
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
|
ifdef USEXBLAS
|
||||||
CLINTST += cdrvgbx.o cdrvgex.o cdrvhex.o cdrvsyx.o cdrvpox.o \
|
CLINTST += cdrvgbx.o cdrvgex.o cdrvhex.o cdrvsyx.o cdrvpox.o \
|
||||||
|
|
@ -168,7 +166,8 @@ DLINTST = dchkaa.o \
|
||||||
dgennd.o \
|
dgennd.o \
|
||||||
dqrt04.o dqrt05.o dchkqrt.o derrqrt.o dchkqrtp.o derrqrtp.o \
|
dqrt04.o dqrt05.o dchkqrt.o derrqrt.o dchkqrtp.o derrqrtp.o \
|
||||||
dchklq.o dchklqt.o dchklqtp.o dchktsqr.o \
|
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
|
ifdef USEXBLAS
|
||||||
DLINTST += ddrvgbx.o ddrvgex.o ddrvsyx.o ddrvpox.o \
|
DLINTST += ddrvgbx.o ddrvgex.o ddrvsyx.o ddrvpox.o \
|
||||||
|
|
@ -215,7 +214,8 @@ ZLINTST = zchkaa.o \
|
||||||
dget06.o zgennd.o \
|
dget06.o zgennd.o \
|
||||||
zqrt04.o zqrt05.o zchkqrt.o zerrqrt.o zchkqrtp.o zerrqrtp.o \
|
zqrt04.o zqrt05.o zchkqrt.o zerrqrt.o zchkqrtp.o zerrqrtp.o \
|
||||||
zchklqt.o zchklqtp.o zchktsqr.o \
|
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
|
ifdef USEXBLAS
|
||||||
ZLINTST += zdrvgbx.o zdrvgex.o zdrvhex.o zdrvsyx.o zdrvpox.o \
|
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 \
|
zlatb4.o zlaipd.o zlarhs.o zsbmv.o zget04.o zpot01.o zpot03.o zpot02.o \
|
||||||
chkxer.o xerbla.o alaerh.o aladhd.o alahd.o alasvm.o
|
chkxer.o xerbla.o alaerh.o aladhd.o alahd.o alasvm.o
|
||||||
|
|
||||||
|
.PHONY: all
|
||||||
all: single double complex complex16 proto-single proto-double proto-complex proto-complex16
|
all: single double complex complex16 proto-single proto-double proto-complex proto-complex16
|
||||||
|
|
||||||
|
.PHONY: single double complex complex16
|
||||||
single: xlintsts
|
single: xlintsts
|
||||||
double: xlintstd
|
double: xlintstd
|
||||||
complex: xlintstc
|
complex: xlintstc
|
||||||
complex16: xlintstz
|
complex16: xlintstz
|
||||||
|
|
||||||
|
.PHONY: proto-single proto-double proto-complex proto-complex16
|
||||||
proto-single: xlintstrfs
|
proto-single: xlintstrfs
|
||||||
proto-double: xlintstds xlintstrfd
|
proto-double: xlintstds xlintstrfd
|
||||||
proto-complex: xlintstrfc
|
proto-complex: xlintstrfc
|
||||||
proto-complex16: xlintstzc xlintstrfz
|
proto-complex16: xlintstzc xlintstrfz
|
||||||
|
|
||||||
xlintsts: $(ALINTST) $(SLINTST) $(SCLNTST) ../../$(TMGLIB) ../../$(LAPACKLIB) $(XBLASLIB) $(BLASLIB)
|
xlintsts: $(ALINTST) $(SLINTST) $(SCLNTST) $(TMGLIB) $(VARLIB) $(LAPACKLIB) $(XBLASLIB) $(BLASLIB)
|
||||||
$(LOADER) $(LOADOPTS) -o $@ $^
|
$(FC) $(FFLAGS) $(LDFLAGS) -o $@ $^
|
||||||
|
|
||||||
xlintstc: $(ALINTST) $(CLINTST) $(SCLNTST) ../../$(TMGLIB) ../../$(LAPACKLIB) $(XBLASLIB) $(BLASLIB)
|
xlintstc: $(ALINTST) $(CLINTST) $(SCLNTST) $(TMGLIB) $(VARLIB) $(LAPACKLIB) $(XBLASLIB) $(BLASLIB)
|
||||||
$(LOADER) $(LOADOPTS) -o $@ $^
|
$(FC) $(FFLAGS) $(LDFLAGS) -o $@ $^
|
||||||
|
|
||||||
xlintstd: $(ALINTST) $(DLINTST) $(DZLNTST) ../../$(TMGLIB) ../../$(LAPACKLIB) $(XBLASLIB) $(BLASLIB)
|
xlintstd: $(ALINTST) $(DLINTST) $(DZLNTST) $(TMGLIB) $(VARLIB) $(LAPACKLIB) $(XBLASLIB) $(BLASLIB)
|
||||||
$(LOADER) $(LOADOPTS) -o $@ $^
|
$(FC) $(FFLAGS) $(LDFLAGS) -o $@ $^
|
||||||
|
|
||||||
xlintstz: $(ALINTST) $(ZLINTST) $(DZLNTST) ../../$(TMGLIB) ../../$(LAPACKLIB) $(XBLASLIB) $(BLASLIB)
|
xlintstz: $(ALINTST) $(ZLINTST) $(DZLNTST) $(TMGLIB) $(VARLIB) $(LAPACKLIB) $(XBLASLIB) $(BLASLIB)
|
||||||
$(LOADER) $(LOADOPTS) -o $@ $^
|
$(FC) $(FFLAGS) $(LDFLAGS) -o $@ $^
|
||||||
|
|
||||||
xlintstds: $(DSLINTST) ../../$(TMGLIB) ../../$(LAPACKLIB) $(BLASLIB)
|
xlintstds: $(DSLINTST) $(TMGLIB) $(VARLIB) $(LAPACKLIB) $(BLASLIB)
|
||||||
$(LOADER) $(LOADOPTS) -o $@ $^
|
$(FC) $(FFLAGS) $(LDFLAGS) -o $@ $^
|
||||||
|
|
||||||
xlintstzc: $(ZCLINTST) ../../$(TMGLIB) ../../$(LAPACKLIB) $(BLASLIB)
|
xlintstzc: $(ZCLINTST) $(TMGLIB) $(VARLIB) $(LAPACKLIB) $(BLASLIB)
|
||||||
$(LOADER) $(LOADOPTS) -o $@ $^
|
$(FC) $(FFLAGS) $(LDFLAGS) -o $@ $^
|
||||||
|
|
||||||
xlintstrfs: $(SLINTSTRFP) ../../$(TMGLIB) ../../$(LAPACKLIB) $(BLASLIB)
|
xlintstrfs: $(SLINTSTRFP) $(TMGLIB) $(VARLIB) $(LAPACKLIB) $(BLASLIB)
|
||||||
$(LOADER) $(LOADOPTS) -o $@ $^
|
$(FC) $(FFLAGS) $(LDFLAGS) -o $@ $^
|
||||||
|
|
||||||
xlintstrfd: $(DLINTSTRFP) ../../$(TMGLIB) ../../$(LAPACKLIB) $(BLASLIB)
|
xlintstrfd: $(DLINTSTRFP) $(TMGLIB) $(VARLIB) $(LAPACKLIB) $(BLASLIB)
|
||||||
$(LOADER) $(LOADOPTS) -o $@ $^
|
$(FC) $(FFLAGS) $(LDFLAGS) -o $@ $^
|
||||||
|
|
||||||
xlintstrfc: $(CLINTSTRFP) ../../$(TMGLIB) ../../$(LAPACKLIB) $(BLASLIB)
|
xlintstrfc: $(CLINTSTRFP) $(TMGLIB) $(VARLIB) $(LAPACKLIB) $(BLASLIB)
|
||||||
$(LOADER) $(LOADOPTS) -o $@ $^
|
$(FC) $(FFLAGS) $(LDFLAGS) -o $@ $^
|
||||||
|
|
||||||
xlintstrfz: $(ZLINTSTRFP) ../../$(TMGLIB) ../../$(LAPACKLIB) $(BLASLIB)
|
xlintstrfz: $(ZLINTSTRFP) $(TMGLIB) $(VARLIB) $(LAPACKLIB) $(BLASLIB)
|
||||||
$(LOADER) $(LOADOPTS) -o $@ $^
|
$(FC) $(FFLAGS) $(LDFLAGS) -o $@ $^
|
||||||
|
|
||||||
$(ALINTST): $(FRC)
|
$(ALINTST): $(FRC)
|
||||||
$(SCLNTST): $(FRC)
|
$(SCLNTST): $(FRC)
|
||||||
|
|
@ -307,6 +310,7 @@ $(ZLINTST): $(FRC)
|
||||||
FRC:
|
FRC:
|
||||||
@FRC=$(FRC)
|
@FRC=$(FRC)
|
||||||
|
|
||||||
|
.PHONY: clean cleanobj cleanexe
|
||||||
clean: cleanobj cleanexe
|
clean: cleanobj cleanexe
|
||||||
cleanobj:
|
cleanobj:
|
||||||
rm -f *.o
|
rm -f *.o
|
||||||
|
|
@ -314,15 +318,12 @@ cleanexe:
|
||||||
rm -f xlintst*
|
rm -f xlintst*
|
||||||
|
|
||||||
schkaa.o: schkaa.f
|
schkaa.o: schkaa.f
|
||||||
$(FORTRAN) $(DRVOPTS) -c -o $@ $<
|
$(FC) $(FFLAGS_DRV) -c -o $@ $<
|
||||||
dchkaa.o: dchkaa.f
|
dchkaa.o: dchkaa.f
|
||||||
$(FORTRAN) $(DRVOPTS) -c -o $@ $<
|
$(FC) $(FFLAGS_DRV) -c -o $@ $<
|
||||||
cchkaa.o: cchkaa.f
|
cchkaa.o: cchkaa.f
|
||||||
$(FORTRAN) $(DRVOPTS) -c -o $@ $<
|
$(FC) $(FFLAGS_DRV) -c -o $@ $<
|
||||||
zchkaa.o: zchkaa.f
|
zchkaa.o: zchkaa.f
|
||||||
$(FORTRAN) $(DRVOPTS) -c -o $@ $<
|
$(FC) $(FFLAGS_DRV) -c -o $@ $<
|
||||||
|
|
||||||
.f.o:
|
|
||||||
$(FORTRAN) $(OPTS) -c -o $@ $<
|
|
||||||
|
|
||||||
.NOTPARALLEL:
|
.NOTPARALLEL:
|
||||||
|
|
|
||||||
|
|
@ -74,6 +74,8 @@
|
||||||
*> CEQ
|
*> CEQ
|
||||||
*> CQT
|
*> CQT
|
||||||
*> CQX
|
*> CQX
|
||||||
|
*> CTS
|
||||||
|
*> CHH
|
||||||
*> \endverbatim
|
*> \endverbatim
|
||||||
*
|
*
|
||||||
* Parameters:
|
* Parameters:
|
||||||
|
|
@ -108,14 +110,14 @@
|
||||||
*> \author Univ. of Colorado Denver
|
*> \author Univ. of Colorado Denver
|
||||||
*> \author NAG Ltd.
|
*> \author NAG Ltd.
|
||||||
*
|
*
|
||||||
*> \date November 2017
|
*> \date November 2019
|
||||||
*
|
*
|
||||||
*> \ingroup complex_lin
|
*> \ingroup complex_lin
|
||||||
*
|
*
|
||||||
* =====================================================================
|
* =====================================================================
|
||||||
PROGRAM CCHKAA
|
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, --
|
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||||
* November 2017
|
* November 2017
|
||||||
|
|
@ -165,15 +167,16 @@
|
||||||
* ..
|
* ..
|
||||||
* .. External Subroutines ..
|
* .. External Subroutines ..
|
||||||
EXTERNAL ALAREQ, CCHKEQ, CCHKGB, CCHKGE, CCHKGT, CCHKHE,
|
EXTERNAL ALAREQ, CCHKEQ, CCHKGB, CCHKGE, CCHKGT, CCHKHE,
|
||||||
$ CCHKHE_ROOK, CCHKHE_RK, CCHKHE_AA, CCHKLQ,
|
$ CCHKHE_ROOK, CCHKHE_RK, CCHKHE_AA, CCHKHP,
|
||||||
$ CCHKPB,CCHKPO, CCHKPS, CCHKPP, CCHKPT, CCHKQ3,
|
$ CCHKLQ, CCHKUNHR_COL, CCHKPB, CCHKPO, CCHKPS,
|
||||||
$ CCHKQL, CCHKQR, CCHKRQ, CCHKSP, CCHKSY,
|
$ CCHKPP, CCHKPT, CCHKQ3, CCHKQL, CCHKQR, CCHKRQ,
|
||||||
$ CCHKSY_ROOK, CCHKSY_RK, CCHKSY_AA, CCHKTB,
|
$ CCHKSP, CCHKSY, CCHKSY_ROOK, CCHKSY_RK,
|
||||||
$ CCHKTP, CCHKTR, CCHKTZ, CDRVGB, CDRVGE, CDRVGT,
|
$ CCHKSY_AA, CCHKTB, CCHKTP, CCHKTR, CCHKTZ,
|
||||||
$ CDRVHE, CDRVHE_ROOK, CDRVHE_RK, CDRVHE_AA,
|
$ CDRVGB, CDRVGE, CDRVGT, CDRVHE, CDRVHE_ROOK,
|
||||||
$ CDRVHP, CDRVLS, CDRVPB, CDRVPO, CDRVPP, CDRVPT,
|
$ CDRVHE_RK, CDRVHE_AA, CDRVHP, CDRVLS, CDRVPB,
|
||||||
$ CDRVSP, CDRVSY, CDRVSY_ROOK, CDRVSY_RK,
|
$ CDRVPO, CDRVPP, CDRVPT, CDRVSP, CDRVSY,
|
||||||
$ CDRVSY_AA, ILAVER, CCHKQRT, CCHKQRTP
|
$ CDRVSY_ROOK, CDRVSY_RK, CDRVSY_AA, ILAVER,
|
||||||
|
$ CCHKQRT, CCHKQRTP
|
||||||
* ..
|
* ..
|
||||||
* .. Scalars in Common ..
|
* .. Scalars in Common ..
|
||||||
LOGICAL LERR, OK
|
LOGICAL LERR, OK
|
||||||
|
|
@ -678,7 +681,7 @@
|
||||||
*
|
*
|
||||||
* HK: Hermitian indefinite matrices,
|
* HK: Hermitian indefinite matrices,
|
||||||
* with bounded Bunch-Kaufman (rook) pivoting algorithm,
|
* 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
|
NTYPES = 10
|
||||||
CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
|
CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
|
||||||
|
|
@ -838,7 +841,7 @@
|
||||||
*
|
*
|
||||||
* SK: symmetric indefinite matrices,
|
* SK: symmetric indefinite matrices,
|
||||||
* with bounded Bunch-Kaufman (rook) pivoting algorithm,
|
* 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
|
NTYPES = 11
|
||||||
CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
|
CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
|
||||||
|
|
@ -1165,6 +1168,17 @@
|
||||||
ELSE
|
ELSE
|
||||||
WRITE( NOUT, FMT = 9989 )PATH
|
WRITE( NOUT, FMT = 9989 )PATH
|
||||||
END IF
|
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
|
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
|
REAL EPS, NORMA, NORMB, RCOND
|
||||||
* ..
|
* ..
|
||||||
* .. Local Arrays ..
|
* .. Local Arrays ..
|
||||||
INTEGER ISEED( 4 ), ISEEDY( 4 ), IWQ
|
INTEGER ISEED( 4 ), ISEEDY( 4 ), IWQ( 1 )
|
||||||
REAL RESULT( NTESTS ), RWQ
|
REAL RESULT( NTESTS ), RWQ( 1 )
|
||||||
COMPLEX WQ
|
COMPLEX WQ( 1 )
|
||||||
* ..
|
* ..
|
||||||
* .. Allocatable Arrays ..
|
* .. Allocatable Arrays ..
|
||||||
COMPLEX, ALLOCATABLE :: WORK (:)
|
COMPLEX, ALLOCATABLE :: WORK (:)
|
||||||
REAL, ALLOCATABLE :: RWORK (:)
|
REAL, ALLOCATABLE :: RWORK (:), WORK2 (:)
|
||||||
INTEGER, ALLOCATABLE :: IWORK (:)
|
INTEGER, ALLOCATABLE :: IWORK (:)
|
||||||
* ..
|
* ..
|
||||||
* .. External Functions ..
|
* .. External Functions ..
|
||||||
|
|
@ -363,32 +363,32 @@
|
||||||
* Compute workspace needed for CGELS
|
* Compute workspace needed for CGELS
|
||||||
CALL CGELS( TRANS, M, N, NRHS, A, LDA,
|
CALL CGELS( TRANS, M, N, NRHS, A, LDA,
|
||||||
$ B, LDB, WQ, -1, INFO )
|
$ B, LDB, WQ, -1, INFO )
|
||||||
LWORK_CGELS = INT( WQ )
|
LWORK_CGELS = INT( WQ( 1 ) )
|
||||||
* Compute workspace needed for CGETSLS
|
* Compute workspace needed for CGETSLS
|
||||||
CALL CGETSLS( TRANS, M, N, NRHS, A, LDA,
|
CALL CGETSLS( TRANS, M, N, NRHS, A, LDA,
|
||||||
$ B, LDB, WQ, -1, INFO )
|
$ B, LDB, WQ, -1, INFO )
|
||||||
LWORK_CGETSLS = INT( WQ )
|
LWORK_CGETSLS = INT( WQ( 1 ) )
|
||||||
ENDDO
|
ENDDO
|
||||||
END IF
|
END IF
|
||||||
* Compute workspace needed for CGELSY
|
* Compute workspace needed for CGELSY
|
||||||
CALL CGELSY( M, N, NRHS, A, LDA, B, LDB,
|
CALL CGELSY( M, N, NRHS, A, LDA, B, LDB,
|
||||||
$ IWQ, RCOND, CRANK, WQ, -1, RWORK,
|
$ IWQ, RCOND, CRANK, WQ, -1, RWORK,
|
||||||
$ INFO )
|
$ INFO )
|
||||||
LWORK_CGELSY = INT( WQ )
|
LWORK_CGELSY = INT( WQ( 1 ) )
|
||||||
LRWORK_CGELSY = 2*N
|
LRWORK_CGELSY = 2*N
|
||||||
* Compute workspace needed for CGELSS
|
* Compute workspace needed for CGELSS
|
||||||
CALL CGELSS( M, N, NRHS, A, LDA, B, LDB, S,
|
CALL CGELSS( M, N, NRHS, A, LDA, B, LDB, S,
|
||||||
$ RCOND, CRANK, WQ, -1, RWORK, INFO )
|
$ RCOND, CRANK, WQ, -1, RWORK, INFO )
|
||||||
LWORK_CGELSS = INT( WQ )
|
LWORK_CGELSS = INT( WQ( 1 ) )
|
||||||
LRWORK_CGELSS = 5*MNMIN
|
LRWORK_CGELSS = 5*MNMIN
|
||||||
* Compute workspace needed for CGELSD
|
* Compute workspace needed for CGELSD
|
||||||
CALL CGELSD( M, N, NRHS, A, LDA, B, LDB, S,
|
CALL CGELSD( M, N, NRHS, A, LDA, B, LDB, S,
|
||||||
$ RCOND, CRANK, WQ, -1, RWQ, IWQ,
|
$ RCOND, CRANK, WQ, -1, RWQ, IWQ,
|
||||||
$ INFO )
|
$ INFO )
|
||||||
LWORK_CGELSD = INT( WQ )
|
LWORK_CGELSD = INT( WQ( 1 ) )
|
||||||
LRWORK_CGELSD = INT( RWQ )
|
LRWORK_CGELSD = INT( RWQ ( 1 ) )
|
||||||
* Compute LIWORK workspace needed for CGELSY and CGELSD
|
* 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
|
* Compute LRWORK workspace needed for CGELSY, CGELSS and CGELSD
|
||||||
LRWORK = MAX( LRWORK, LRWORK_CGELSY,
|
LRWORK = MAX( LRWORK, LRWORK_CGELSY,
|
||||||
$ LRWORK_CGELSS, LRWORK_CGELSD )
|
$ LRWORK_CGELSS, LRWORK_CGELSD )
|
||||||
|
|
@ -408,6 +408,7 @@
|
||||||
ALLOCATE( WORK( LWORK ) )
|
ALLOCATE( WORK( LWORK ) )
|
||||||
ALLOCATE( IWORK( LIWORK ) )
|
ALLOCATE( IWORK( LIWORK ) )
|
||||||
ALLOCATE( RWORK( LRWORK ) )
|
ALLOCATE( RWORK( LRWORK ) )
|
||||||
|
ALLOCATE( WORK2( 2 * LWORK ) )
|
||||||
*
|
*
|
||||||
DO 140 IM = 1, NM
|
DO 140 IM = 1, NM
|
||||||
M = MVAL( IM )
|
M = MVAL( IM )
|
||||||
|
|
@ -596,7 +597,7 @@
|
||||||
$ CALL CLACPY( 'Full', NROWS, NRHS,
|
$ CALL CLACPY( 'Full', NROWS, NRHS,
|
||||||
$ COPYB, LDB, C, LDB )
|
$ COPYB, LDB, C, LDB )
|
||||||
CALL CQRT16( TRANS, M, N, NRHS, COPYA,
|
CALL CQRT16( TRANS, M, N, NRHS, COPYA,
|
||||||
$ LDA, B, LDB, C, LDB, WORK,
|
$ LDA, B, LDB, C, LDB, WORK2,
|
||||||
$ RESULT( 15 ) )
|
$ RESULT( 15 ) )
|
||||||
*
|
*
|
||||||
IF( ( ITRAN.EQ.1 .AND. M.GE.N ) .OR.
|
IF( ( ITRAN.EQ.1 .AND. M.GE.N ) .OR.
|
||||||
|
|
|
||||||
|
|
@ -98,8 +98,9 @@
|
||||||
*> \param[out] E
|
*> \param[out] E
|
||||||
*> \verbatim
|
*> \verbatim
|
||||||
*> E is COMPLEX array, dimension (NMAX)
|
*> E is COMPLEX array, dimension (NMAX)
|
||||||
*> \param[out] AINV
|
*> \endverbatim
|
||||||
*>
|
*>
|
||||||
|
*> \param[out] AINV
|
||||||
*> \verbatim
|
*> \verbatim
|
||||||
*> AINV is COMPLEX array, dimension (NMAX*NMAX)
|
*> AINV is COMPLEX array, dimension (NMAX*NMAX)
|
||||||
*> \endverbatim
|
*> \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 )
|
$ W, 1, INFO )
|
||||||
CALL CHKXER( 'CHESV_AA_2STAGE', INFOT, NOUT, LERR, OK )
|
CALL CHKXER( 'CHESV_AA_2STAGE', INFOT, NOUT, LERR, OK )
|
||||||
INFOT = 11
|
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 )
|
$ W, 1, INFO )
|
||||||
CALL CHKXER( 'CHESV_AA_2STAGE', INFOT, NOUT, LERR, OK )
|
CALL CHKXER( 'CHESV_AA_2STAGE', INFOT, NOUT, LERR, OK )
|
||||||
INFOT = 7
|
INFOT = 7
|
||||||
|
|
@ -769,7 +769,7 @@
|
||||||
$ W, 1, INFO )
|
$ W, 1, INFO )
|
||||||
CALL CHKXER( 'CSYSV_AA_2STAGE', INFOT, NOUT, LERR, OK )
|
CALL CHKXER( 'CSYSV_AA_2STAGE', INFOT, NOUT, LERR, OK )
|
||||||
INFOT = 11
|
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 )
|
$ W, 1, INFO )
|
||||||
CALL CHKXER( 'CSYSV_AA_2STAGE', INFOT, NOUT, LERR, OK )
|
CALL CHKXER( 'CSYSV_AA_2STAGE', INFOT, NOUT, LERR, OK )
|
||||||
INFOT = 7
|
INFOT = 7
|
||||||
|
|
|
||||||
|
|
@ -164,7 +164,7 @@
|
||||||
INTEGER NMAX_EXACT, NMAX_APPROX, SIZE_D
|
INTEGER NMAX_EXACT, NMAX_APPROX, SIZE_D
|
||||||
PARAMETER (NMAX_EXACT = 6, NMAX_APPROX = 11, SIZE_D = 8)
|
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)
|
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 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)/
|
DATA D2 /(-1,0),(0,-1),(-1,1),(0,1),(1,0),(-1,-1),(1,-1),(1,1)/
|
||||||
|
|
|
||||||
|
|
@ -114,7 +114,7 @@
|
||||||
* ..
|
* ..
|
||||||
* .. Local Arrays ..
|
* .. Local Arrays ..
|
||||||
INTEGER ISEED( 4 )
|
INTEGER ISEED( 4 )
|
||||||
COMPLEX TQUERY( 5 ), WORKQUERY
|
COMPLEX TQUERY( 5 ), WORKQUERY( 1 )
|
||||||
* ..
|
* ..
|
||||||
* .. External Functions ..
|
* .. External Functions ..
|
||||||
REAL SLAMCH, CLANGE, CLANSY
|
REAL SLAMCH, CLANGE, CLANSY
|
||||||
|
|
@ -173,22 +173,22 @@
|
||||||
*
|
*
|
||||||
CALL CGEQR( M, N, AF, M, TQUERY, -1, WORKQUERY, -1, INFO )
|
CALL CGEQR( M, N, AF, M, TQUERY, -1, WORKQUERY, -1, INFO )
|
||||||
TSIZE = INT( TQUERY( 1 ) )
|
TSIZE = INT( TQUERY( 1 ) )
|
||||||
LWORK = INT( WORKQUERY )
|
LWORK = INT( WORKQUERY( 1 ) )
|
||||||
CALL CGEMQR( 'L', 'N', M, M, K, AF, M, TQUERY, TSIZE, CF, M,
|
CALL CGEMQR( 'L', 'N', M, M, K, AF, M, TQUERY, TSIZE, CF, M,
|
||||||
$ WORKQUERY, -1, INFO)
|
$ 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,
|
CALL CGEMQR( 'L', 'N', M, N, K, AF, M, TQUERY, TSIZE, CF, M,
|
||||||
$ WORKQUERY, -1, INFO)
|
$ 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,
|
CALL CGEMQR( 'L', 'C', M, N, K, AF, M, TQUERY, TSIZE, CF, M,
|
||||||
$ WORKQUERY, -1, INFO)
|
$ 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,
|
CALL CGEMQR( 'R', 'N', N, M, K, AF, M, TQUERY, TSIZE, DF, N,
|
||||||
$ WORKQUERY, -1, INFO)
|
$ 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,
|
CALL CGEMQR( 'R', 'C', N, M, K, AF, M, TQUERY, TSIZE, DF, N,
|
||||||
$ WORKQUERY, -1, INFO)
|
$ WORKQUERY, -1, INFO)
|
||||||
LWORK = MAX( LWORK, INT( WORKQUERY ) )
|
LWORK = MAX( LWORK, INT( WORKQUERY( 1 ) ) )
|
||||||
ALLOCATE ( T( TSIZE ) )
|
ALLOCATE ( T( TSIZE ) )
|
||||||
ALLOCATE ( WORK( LWORK ) )
|
ALLOCATE ( WORK( LWORK ) )
|
||||||
srnamt = 'CGEQR'
|
srnamt = 'CGEQR'
|
||||||
|
|
@ -316,22 +316,22 @@
|
||||||
ELSE
|
ELSE
|
||||||
CALL CGELQ( M, N, AF, M, TQUERY, -1, WORKQUERY, -1, INFO )
|
CALL CGELQ( M, N, AF, M, TQUERY, -1, WORKQUERY, -1, INFO )
|
||||||
TSIZE = INT( TQUERY( 1 ) )
|
TSIZE = INT( TQUERY( 1 ) )
|
||||||
LWORK = INT( WORKQUERY )
|
LWORK = INT( WORKQUERY( 1 ) )
|
||||||
CALL CGEMLQ( 'R', 'N', N, N, K, AF, M, TQUERY, TSIZE, Q, N,
|
CALL CGEMLQ( 'R', 'N', N, N, K, AF, M, TQUERY, TSIZE, Q, N,
|
||||||
$ WORKQUERY, -1, INFO )
|
$ 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,
|
CALL CGEMLQ( 'L', 'N', N, M, K, AF, M, TQUERY, TSIZE, DF, N,
|
||||||
$ WORKQUERY, -1, INFO)
|
$ 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,
|
CALL CGEMLQ( 'L', 'C', N, M, K, AF, M, TQUERY, TSIZE, DF, N,
|
||||||
$ WORKQUERY, -1, INFO)
|
$ 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,
|
CALL CGEMLQ( 'R', 'N', M, N, K, AF, M, TQUERY, TSIZE, CF, M,
|
||||||
$ WORKQUERY, -1, INFO)
|
$ 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,
|
CALL CGEMLQ( 'R', 'C', M, N, K, AF, M, TQUERY, TSIZE, CF, M,
|
||||||
$ WORKQUERY, -1, INFO)
|
$ WORKQUERY, -1, INFO)
|
||||||
LWORK = MAX( LWORK, INT( WORKQUERY ) )
|
LWORK = MAX( LWORK, INT( WORKQUERY( 1 ) ) )
|
||||||
ALLOCATE ( T( TSIZE ) )
|
ALLOCATE ( T( TSIZE ) )
|
||||||
ALLOCATE ( WORK( LWORK ) )
|
ALLOCATE ( WORK( LWORK ) )
|
||||||
srnamt = 'CGELQ'
|
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
|
*> DEQ
|
||||||
*> DQT
|
*> DQT
|
||||||
*> DQX
|
*> DQX
|
||||||
|
*> DTQ
|
||||||
|
*> DXQ
|
||||||
|
*> DTS
|
||||||
|
*> DHH
|
||||||
*> \endverbatim
|
*> \endverbatim
|
||||||
*
|
*
|
||||||
* Parameters:
|
* Parameters:
|
||||||
|
|
@ -102,17 +106,17 @@
|
||||||
*> \author Univ. of Colorado Denver
|
*> \author Univ. of Colorado Denver
|
||||||
*> \author NAG Ltd.
|
*> \author NAG Ltd.
|
||||||
*
|
*
|
||||||
*> \date April 2012
|
*> \date November 2019
|
||||||
*
|
*
|
||||||
*> \ingroup double_lin
|
*> \ingroup double_lin
|
||||||
*
|
*
|
||||||
* =====================================================================
|
* =====================================================================
|
||||||
PROGRAM DCHKAA
|
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, --
|
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||||
* April 2012
|
* Novemebr 2019
|
||||||
*
|
*
|
||||||
* =====================================================================
|
* =====================================================================
|
||||||
*
|
*
|
||||||
|
|
@ -159,15 +163,14 @@
|
||||||
* ..
|
* ..
|
||||||
* .. External Subroutines ..
|
* .. External Subroutines ..
|
||||||
EXTERNAL ALAREQ, DCHKEQ, DCHKGB, DCHKGE, DCHKGT, DCHKLQ,
|
EXTERNAL ALAREQ, DCHKEQ, DCHKGB, DCHKGE, DCHKGT, DCHKLQ,
|
||||||
$ DCHKPB, DCHKPO, DCHKPS, DCHKPP, DCHKPT, DCHKQ3,
|
$ DCHKORHR_COL, DCHKPB, DCHKPO, DCHKPS, DCHKPP,
|
||||||
$ DCHKQL, DCHKQR, DCHKRQ, DCHKSP, DCHKSY,
|
$ DCHKPT, DCHKQ3, DCHKQL, DCHKQR, DCHKRQ, DCHKSP,
|
||||||
$ DCHKSY_ROOK, DCHKSY_RK, DCHKSY_AA, DCHKTB,
|
$ DCHKSY, DCHKSY_ROOK, DCHKSY_RK, DCHKSY_AA,
|
||||||
$ DCHKTP, DCHKTR, DCHKTZ, DDRVGB, DDRVGE,
|
$ DCHKTB, DCHKTP, DCHKTR, DCHKTZ, DDRVGB, DDRVGE,
|
||||||
$ DDRVGT, DDRVLS, DDRVPB, DDRVPO, DDRVPP,
|
$ DDRVGT, DDRVLS, DDRVPB, DDRVPO, DDRVPP, DDRVPT,
|
||||||
$ DDRVPT, DDRVSP, DDRVSY, DDRVSY_ROOK, DDRVSY_RK,
|
$ DDRVSP, DDRVSY, DDRVSY_ROOK, DDRVSY_RK,
|
||||||
$ DDRVSY_AA, ILAVER, DCHKQRT,
|
$ DDRVSY_AA, ILAVER, DCHKLQTP, DCHKQRT, DCHKQRTP,
|
||||||
$ DCHKQRTP, DCHKLQTP, DCHKTSQR, DCHKLQT
|
$ DCHKLQT,DCHKTSQR
|
||||||
|
|
||||||
* ..
|
* ..
|
||||||
* .. Scalars in Common ..
|
* .. Scalars in Common ..
|
||||||
LOGICAL LERR, OK
|
LOGICAL LERR, OK
|
||||||
|
|
@ -1007,8 +1010,20 @@
|
||||||
ELSE
|
ELSE
|
||||||
WRITE( NOUT, FMT = 9989 )PATH
|
WRITE( NOUT, FMT = 9989 )PATH
|
||||||
END IF
|
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
|
ELSE
|
||||||
|
|
||||||
*
|
*
|
||||||
WRITE( NOUT, FMT = 9990 )PATH
|
WRITE( NOUT, FMT = 9990 )PATH
|
||||||
END IF
|
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
|
DOUBLE PRECISION EPS, NORMA, NORMB, RCOND
|
||||||
* ..
|
* ..
|
||||||
* .. Local Arrays ..
|
* .. Local Arrays ..
|
||||||
INTEGER ISEED( 4 ), ISEEDY( 4 ), IWQ
|
INTEGER ISEED( 4 ), ISEEDY( 4 ), IWQ( 1 )
|
||||||
DOUBLE PRECISION RESULT( NTESTS ), WQ
|
DOUBLE PRECISION RESULT( NTESTS ), WQ( 1 )
|
||||||
* ..
|
* ..
|
||||||
* .. Allocatable Arrays ..
|
* .. Allocatable Arrays ..
|
||||||
DOUBLE PRECISION, ALLOCATABLE :: WORK (:)
|
DOUBLE PRECISION, ALLOCATABLE :: WORK (:)
|
||||||
|
|
@ -359,27 +359,27 @@
|
||||||
* Compute workspace needed for DGELS
|
* Compute workspace needed for DGELS
|
||||||
CALL DGELS( TRANS, M, N, NRHS, A, LDA,
|
CALL DGELS( TRANS, M, N, NRHS, A, LDA,
|
||||||
$ B, LDB, WQ, -1, INFO )
|
$ B, LDB, WQ, -1, INFO )
|
||||||
LWORK_DGELS = INT ( WQ )
|
LWORK_DGELS = INT ( WQ ( 1 ) )
|
||||||
* Compute workspace needed for DGETSLS
|
* Compute workspace needed for DGETSLS
|
||||||
CALL DGETSLS( TRANS, M, N, NRHS, A, LDA,
|
CALL DGETSLS( TRANS, M, N, NRHS, A, LDA,
|
||||||
$ B, LDB, WQ, -1, INFO )
|
$ B, LDB, WQ, -1, INFO )
|
||||||
LWORK_DGETSLS = INT( WQ )
|
LWORK_DGETSLS = INT( WQ ( 1 ) )
|
||||||
ENDDO
|
ENDDO
|
||||||
END IF
|
END IF
|
||||||
* Compute workspace needed for DGELSY
|
* Compute workspace needed for DGELSY
|
||||||
CALL DGELSY( M, N, NRHS, A, LDA, B, LDB, IWQ,
|
CALL DGELSY( M, N, NRHS, A, LDA, B, LDB, IWQ,
|
||||||
$ RCOND, CRANK, WQ, -1, INFO )
|
$ RCOND, CRANK, WQ, -1, INFO )
|
||||||
LWORK_DGELSY = INT( WQ )
|
LWORK_DGELSY = INT( WQ ( 1 ) )
|
||||||
* Compute workspace needed for DGELSS
|
* Compute workspace needed for DGELSS
|
||||||
CALL DGELSS( M, N, NRHS, A, LDA, B, LDB, S,
|
CALL DGELSS( M, N, NRHS, A, LDA, B, LDB, S,
|
||||||
$ RCOND, CRANK, WQ, -1 , INFO )
|
$ RCOND, CRANK, WQ, -1 , INFO )
|
||||||
LWORK_DGELSS = INT( WQ )
|
LWORK_DGELSS = INT( WQ ( 1 ) )
|
||||||
* Compute workspace needed for DGELSD
|
* Compute workspace needed for DGELSD
|
||||||
CALL DGELSD( M, N, NRHS, A, LDA, B, LDB, S,
|
CALL DGELSD( M, N, NRHS, A, LDA, B, LDB, S,
|
||||||
$ RCOND, CRANK, WQ, -1, IWQ, INFO )
|
$ RCOND, CRANK, WQ, -1, IWQ, INFO )
|
||||||
LWORK_DGELSD = INT( WQ )
|
LWORK_DGELSD = INT( WQ ( 1 ) )
|
||||||
* Compute LIWORK workspace needed for DGELSY and DGELSD
|
* 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
|
* Compute LWORK workspace needed for all functions
|
||||||
LWORK = MAX( LWORK, LWORK_DGELS, LWORK_DGETSLS,
|
LWORK = MAX( LWORK, LWORK_DGELS, LWORK_DGETSLS,
|
||||||
$ LWORK_DGELSY, LWORK_DGELSS,
|
$ 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 )
|
$ W, 1, INFO )
|
||||||
CALL CHKXER( 'DSYSV_AA_2STAGE', INFOT, NOUT, LERR, OK )
|
CALL CHKXER( 'DSYSV_AA_2STAGE', INFOT, NOUT, LERR, OK )
|
||||||
INFOT = 11
|
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 )
|
$ W, 1, INFO )
|
||||||
CALL CHKXER( 'DSYSV_AA_2STAGE', INFOT, NOUT, LERR, OK )
|
CALL CHKXER( 'DSYSV_AA_2STAGE', INFOT, NOUT, LERR, OK )
|
||||||
INFOT = 7
|
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 ..
|
* .. Local Arrays ..
|
||||||
INTEGER ISEED( 4 )
|
INTEGER ISEED( 4 )
|
||||||
DOUBLE PRECISION TQUERY( 5 ), WORKQUERY
|
DOUBLE PRECISION TQUERY( 5 ), WORKQUERY( 1 )
|
||||||
* ..
|
* ..
|
||||||
* .. External Functions ..
|
* .. External Functions ..
|
||||||
DOUBLE PRECISION DLAMCH, DLANGE, DLANSY
|
DOUBLE PRECISION DLAMCH, DLANGE, DLANSY
|
||||||
|
|
@ -174,22 +174,22 @@
|
||||||
*
|
*
|
||||||
CALL DGEQR( M, N, AF, M, TQUERY, -1, WORKQUERY, -1, INFO )
|
CALL DGEQR( M, N, AF, M, TQUERY, -1, WORKQUERY, -1, INFO )
|
||||||
TSIZE = INT( TQUERY( 1 ) )
|
TSIZE = INT( TQUERY( 1 ) )
|
||||||
LWORK = INT( WORKQUERY )
|
LWORK = INT( WORKQUERY( 1 ) )
|
||||||
CALL DGEMQR( 'L', 'N', M, M, K, AF, M, TQUERY, TSIZE, CF, M,
|
CALL DGEMQR( 'L', 'N', M, M, K, AF, M, TQUERY, TSIZE, CF, M,
|
||||||
$ WORKQUERY, -1, INFO)
|
$ 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,
|
CALL DGEMQR( 'L', 'N', M, N, K, AF, M, TQUERY, TSIZE, CF, M,
|
||||||
$ WORKQUERY, -1, INFO)
|
$ 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,
|
CALL DGEMQR( 'L', 'T', M, N, K, AF, M, TQUERY, TSIZE, CF, M,
|
||||||
$ WORKQUERY, -1, INFO)
|
$ 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,
|
CALL DGEMQR( 'R', 'N', N, M, K, AF, M, TQUERY, TSIZE, DF, N,
|
||||||
$ WORKQUERY, -1, INFO)
|
$ 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,
|
CALL DGEMQR( 'R', 'T', N, M, K, AF, M, TQUERY, TSIZE, DF, N,
|
||||||
$ WORKQUERY, -1, INFO)
|
$ WORKQUERY, -1, INFO)
|
||||||
LWORK = MAX( LWORK, INT( WORKQUERY ) )
|
LWORK = MAX( LWORK, INT( WORKQUERY( 1 ) ) )
|
||||||
ALLOCATE ( T( TSIZE ) )
|
ALLOCATE ( T( TSIZE ) )
|
||||||
ALLOCATE ( WORK( LWORK ) )
|
ALLOCATE ( WORK( LWORK ) )
|
||||||
srnamt = 'DGEQR'
|
srnamt = 'DGEQR'
|
||||||
|
|
@ -317,22 +317,22 @@
|
||||||
ELSE
|
ELSE
|
||||||
CALL DGELQ( M, N, AF, M, TQUERY, -1, WORKQUERY, -1, INFO )
|
CALL DGELQ( M, N, AF, M, TQUERY, -1, WORKQUERY, -1, INFO )
|
||||||
TSIZE = INT( TQUERY( 1 ) )
|
TSIZE = INT( TQUERY( 1 ) )
|
||||||
LWORK = INT( WORKQUERY )
|
LWORK = INT( WORKQUERY( 1 ) )
|
||||||
CALL DGEMLQ( 'R', 'N', N, N, K, AF, M, TQUERY, TSIZE, Q, N,
|
CALL DGEMLQ( 'R', 'N', N, N, K, AF, M, TQUERY, TSIZE, Q, N,
|
||||||
$ WORKQUERY, -1, INFO )
|
$ 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,
|
CALL DGEMLQ( 'L', 'N', N, M, K, AF, M, TQUERY, TSIZE, DF, N,
|
||||||
$ WORKQUERY, -1, INFO)
|
$ 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,
|
CALL DGEMLQ( 'L', 'T', N, M, K, AF, M, TQUERY, TSIZE, DF, N,
|
||||||
$ WORKQUERY, -1, INFO)
|
$ 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,
|
CALL DGEMLQ( 'R', 'N', M, N, K, AF, M, TQUERY, TSIZE, CF, M,
|
||||||
$ WORKQUERY, -1, INFO)
|
$ 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,
|
CALL DGEMLQ( 'R', 'T', M, N, K, AF, M, TQUERY, TSIZE, CF, M,
|
||||||
$ WORKQUERY, -1, INFO)
|
$ WORKQUERY, -1, INFO)
|
||||||
LWORK = MAX( LWORK, INT( WORKQUERY ) )
|
LWORK = MAX( LWORK, INT( WORKQUERY( 1 ) ) )
|
||||||
ALLOCATE ( T( TSIZE ) )
|
ALLOCATE ( T( TSIZE ) )
|
||||||
ALLOCATE ( WORK( LWORK ) )
|
ALLOCATE ( WORK( LWORK ) )
|
||||||
srnamt = 'DGELQ'
|
srnamt = 'DGELQ'
|
||||||
|
|
|
||||||
|
|
@ -68,6 +68,8 @@
|
||||||
*> SEQ
|
*> SEQ
|
||||||
*> SQT
|
*> SQT
|
||||||
*> SQX
|
*> SQX
|
||||||
|
*> STS
|
||||||
|
*> SHH
|
||||||
*> \endverbatim
|
*> \endverbatim
|
||||||
*
|
*
|
||||||
* Parameters:
|
* Parameters:
|
||||||
|
|
@ -102,17 +104,17 @@
|
||||||
*> \author Univ. of Colorado Denver
|
*> \author Univ. of Colorado Denver
|
||||||
*> \author NAG Ltd.
|
*> \author NAG Ltd.
|
||||||
*
|
*
|
||||||
*> \date April 2012
|
*> \date November 2019
|
||||||
*
|
*
|
||||||
*> \ingroup single_lin
|
*> \ingroup single_lin
|
||||||
*
|
*
|
||||||
* =====================================================================
|
* =====================================================================
|
||||||
PROGRAM SCHKAA
|
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, --
|
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||||
* April 2012
|
* November 2019
|
||||||
*
|
*
|
||||||
* =====================================================================
|
* =====================================================================
|
||||||
*
|
*
|
||||||
|
|
@ -159,13 +161,13 @@
|
||||||
* ..
|
* ..
|
||||||
* .. External Subroutines ..
|
* .. External Subroutines ..
|
||||||
EXTERNAL ALAREQ, SCHKEQ, SCHKGB, SCHKGE, SCHKGT, SCHKLQ,
|
EXTERNAL ALAREQ, SCHKEQ, SCHKGB, SCHKGE, SCHKGT, SCHKLQ,
|
||||||
$ SCHKPB, SCHKPO, SCHKPS, SCHKPP, SCHKPT, SCHKQ3,
|
$ SCHKORHR_COL, SCHKPB, SCHKPO, SCHKPS, SCHKPP,
|
||||||
$ SCHKQL, SCHKQR, SCHKRQ, SCHKSP, SCHKSY,
|
$ SCHKPT, SCHKQ3, SCHKQL, SCHKQR, SCHKRQ, SCHKSP,
|
||||||
$ SCHKSY_ROOK, SCHKSY_RK, SCHKSY_AA, SCHKTB,
|
$ SCHKSY, SCHKSY_ROOK, SCHKSY_RK, SCHKSY_AA,
|
||||||
$ SCHKTP, SCHKTR, SCHKTZ, SDRVGB, SDRVGE, SDRVGT,
|
$ SCHKTB, SCHKTP, SCHKTR, SCHKTZ, SDRVGB, SDRVGE,
|
||||||
$ SDRVLS, SDRVPB, SDRVPO, SDRVPP, SDRVPT, SDRVSP,
|
$ SDRVGT, SDRVLS, SDRVPB, SDRVPO, SDRVPP, SDRVPT,
|
||||||
$ SDRVSY, SDRVSY_ROOK, SDRVSY_RK, SDRVSY_AA,
|
$ SDRVSP, SDRVSY, SDRVSY_ROOK, SDRVSY_RK,
|
||||||
$ ILAVER, SCHKLQTP, SCHKQRT, SCHKQRTP,
|
$ SDRVSY_AA, ILAVER, SCHKLQTP, SCHKQRT, SCHKQRTP,
|
||||||
$ SCHKLQT, SCHKTSQR
|
$ SCHKLQT, SCHKTSQR
|
||||||
* ..
|
* ..
|
||||||
* .. Scalars in Common ..
|
* .. Scalars in Common ..
|
||||||
|
|
@ -673,7 +675,7 @@
|
||||||
*
|
*
|
||||||
* SK: symmetric indefinite matrices,
|
* SK: symmetric indefinite matrices,
|
||||||
* with bounded Bunch-Kaufman (rook) pivoting algorithm,
|
* 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
|
NTYPES = 10
|
||||||
CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
|
CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
|
||||||
|
|
@ -1004,6 +1006,17 @@
|
||||||
ELSE
|
ELSE
|
||||||
WRITE( NOUT, FMT = 9989 )PATH
|
WRITE( NOUT, FMT = 9989 )PATH
|
||||||
END IF
|
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
|
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
|
REAL EPS, NORMA, NORMB, RCOND
|
||||||
* ..
|
* ..
|
||||||
* .. Local Arrays ..
|
* .. Local Arrays ..
|
||||||
INTEGER ISEED( 4 ), ISEEDY( 4 ), IWQ
|
INTEGER ISEED( 4 ), ISEEDY( 4 ), IWQ( 1 )
|
||||||
REAL RESULT( NTESTS ), WQ
|
REAL RESULT( NTESTS ), WQ( 1 )
|
||||||
* ..
|
* ..
|
||||||
* .. Allocatable Arrays ..
|
* .. Allocatable Arrays ..
|
||||||
REAL, ALLOCATABLE :: WORK (:)
|
REAL, ALLOCATABLE :: WORK (:)
|
||||||
|
|
@ -358,28 +358,28 @@
|
||||||
*
|
*
|
||||||
* Compute workspace needed for SGELS
|
* Compute workspace needed for SGELS
|
||||||
CALL SGELS( TRANS, M, N, NRHS, A, LDA,
|
CALL SGELS( TRANS, M, N, NRHS, A, LDA,
|
||||||
$ B, LDB, WQ, -1, INFO )
|
$ B, LDB, WQ( 1 ), -1, INFO )
|
||||||
LWORK_SGELS = INT ( WQ )
|
LWORK_SGELS = INT ( WQ( 1 ) )
|
||||||
* Compute workspace needed for SGETSLS
|
* Compute workspace needed for SGETSLS
|
||||||
CALL SGETSLS( TRANS, M, N, NRHS, A, LDA,
|
CALL SGETSLS( TRANS, M, N, NRHS, A, LDA,
|
||||||
$ B, LDB, WQ, -1, INFO )
|
$ B, LDB, WQ( 1 ), -1, INFO )
|
||||||
LWORK_SGETSLS = INT( WQ )
|
LWORK_SGETSLS = INT( WQ( 1 ) )
|
||||||
ENDDO
|
ENDDO
|
||||||
END IF
|
END IF
|
||||||
* Compute workspace needed for SGELSY
|
* Compute workspace needed for SGELSY
|
||||||
CALL SGELSY( M, N, NRHS, A, LDA, B, LDB, IWQ,
|
CALL SGELSY( M, N, NRHS, A, LDA, B, LDB, IWQ,
|
||||||
$ RCOND, CRANK, WQ, -1, INFO )
|
$ RCOND, CRANK, WQ, -1, INFO )
|
||||||
LWORK_SGELSY = INT( WQ )
|
LWORK_SGELSY = INT( WQ( 1 ) )
|
||||||
* Compute workspace needed for SGELSS
|
* Compute workspace needed for SGELSS
|
||||||
CALL SGELSS( M, N, NRHS, A, LDA, B, LDB, S,
|
CALL SGELSS( M, N, NRHS, A, LDA, B, LDB, S,
|
||||||
$ RCOND, CRANK, WQ, -1 , INFO )
|
$ RCOND, CRANK, WQ, -1 , INFO )
|
||||||
LWORK_SGELSS = INT( WQ )
|
LWORK_SGELSS = INT( WQ( 1 ) )
|
||||||
* Compute workspace needed for SGELSD
|
* Compute workspace needed for SGELSD
|
||||||
CALL SGELSD( M, N, NRHS, A, LDA, B, LDB, S,
|
CALL SGELSD( M, N, NRHS, A, LDA, B, LDB, S,
|
||||||
$ RCOND, CRANK, WQ, -1, IWQ, INFO )
|
$ RCOND, CRANK, WQ, -1, IWQ, INFO )
|
||||||
LWORK_SGELSD = INT( WQ )
|
LWORK_SGELSD = INT( WQ( 1 ) )
|
||||||
* Compute LIWORK workspace needed for SGELSY and SGELSD
|
* 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
|
* Compute LWORK workspace needed for all functions
|
||||||
LWORK = MAX( LWORK, LWORK_SGELS, LWORK_SGETSLS,
|
LWORK = MAX( LWORK, LWORK_SGELS, LWORK_SGETSLS,
|
||||||
$ LWORK_SGELSY, LWORK_SGELSS,
|
$ 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 )
|
$ W, 1, INFO )
|
||||||
CALL CHKXER( 'SSYSV_AA_2STAGE', INFOT, NOUT, LERR, OK )
|
CALL CHKXER( 'SSYSV_AA_2STAGE', INFOT, NOUT, LERR, OK )
|
||||||
INFOT = 11
|
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 )
|
$ W, 1, INFO )
|
||||||
CALL CHKXER( 'SSYSV_AA_2STAGE', INFOT, NOUT, LERR, OK )
|
CALL CHKXER( 'SSYSV_AA_2STAGE', INFOT, NOUT, LERR, OK )
|
||||||
INFOT = 7
|
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 ..
|
* .. Local Arrays ..
|
||||||
INTEGER ISEED( 4 )
|
INTEGER ISEED( 4 )
|
||||||
REAL TQUERY( 5 ), WORKQUERY
|
REAL TQUERY( 5 ), WORKQUERY( 1 )
|
||||||
* ..
|
* ..
|
||||||
* .. External Functions ..
|
* .. External Functions ..
|
||||||
REAL SLAMCH, SLANGE, SLANSY
|
REAL SLAMCH, SLANGE, SLANSY
|
||||||
|
|
@ -174,22 +174,22 @@
|
||||||
*
|
*
|
||||||
CALL SGEQR( M, N, AF, M, TQUERY, -1, WORKQUERY, -1, INFO )
|
CALL SGEQR( M, N, AF, M, TQUERY, -1, WORKQUERY, -1, INFO )
|
||||||
TSIZE = INT( TQUERY( 1 ) )
|
TSIZE = INT( TQUERY( 1 ) )
|
||||||
LWORK = INT( WORKQUERY )
|
LWORK = INT( WORKQUERY( 1 ) )
|
||||||
CALL SGEMQR( 'L', 'N', M, M, K, AF, M, TQUERY, TSIZE, CF, M,
|
CALL SGEMQR( 'L', 'N', M, M, K, AF, M, TQUERY, TSIZE, CF, M,
|
||||||
$ WORKQUERY, -1, INFO)
|
$ 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,
|
CALL SGEMQR( 'L', 'N', M, N, K, AF, M, TQUERY, TSIZE, CF, M,
|
||||||
$ WORKQUERY, -1, INFO)
|
$ 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,
|
CALL SGEMQR( 'L', 'T', M, N, K, AF, M, TQUERY, TSIZE, CF, M,
|
||||||
$ WORKQUERY, -1, INFO)
|
$ 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,
|
CALL SGEMQR( 'R', 'N', N, M, K, AF, M, TQUERY, TSIZE, DF, N,
|
||||||
$ WORKQUERY, -1, INFO)
|
$ 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,
|
CALL SGEMQR( 'R', 'T', N, M, K, AF, M, TQUERY, TSIZE, DF, N,
|
||||||
$ WORKQUERY, -1, INFO)
|
$ WORKQUERY, -1, INFO)
|
||||||
LWORK = MAX( LWORK, INT( WORKQUERY ) )
|
LWORK = MAX( LWORK, INT( WORKQUERY( 1 ) ) )
|
||||||
ALLOCATE ( T( TSIZE ) )
|
ALLOCATE ( T( TSIZE ) )
|
||||||
ALLOCATE ( WORK( LWORK ) )
|
ALLOCATE ( WORK( LWORK ) )
|
||||||
srnamt = 'SGEQR'
|
srnamt = 'SGEQR'
|
||||||
|
|
@ -317,22 +317,22 @@
|
||||||
ELSE
|
ELSE
|
||||||
CALL SGELQ( M, N, AF, M, TQUERY, -1, WORKQUERY, -1, INFO )
|
CALL SGELQ( M, N, AF, M, TQUERY, -1, WORKQUERY, -1, INFO )
|
||||||
TSIZE = INT( TQUERY( 1 ) )
|
TSIZE = INT( TQUERY( 1 ) )
|
||||||
LWORK = INT( WORKQUERY )
|
LWORK = INT( WORKQUERY( 1 ))
|
||||||
CALL SGEMLQ( 'R', 'N', N, N, K, AF, M, TQUERY, TSIZE, Q, N,
|
CALL SGEMLQ( 'R', 'N', N, N, K, AF, M, TQUERY, TSIZE, Q, N,
|
||||||
$ WORKQUERY, -1, INFO )
|
$ 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,
|
CALL SGEMLQ( 'L', 'N', N, M, K, AF, M, TQUERY, TSIZE, DF, N,
|
||||||
$ WORKQUERY, -1, INFO)
|
$ 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,
|
CALL SGEMLQ( 'L', 'T', N, M, K, AF, M, TQUERY, TSIZE, DF, N,
|
||||||
$ WORKQUERY, -1, INFO)
|
$ 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,
|
CALL SGEMLQ( 'R', 'N', M, N, K, AF, M, TQUERY, TSIZE, CF, M,
|
||||||
$ WORKQUERY, -1, INFO)
|
$ 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,
|
CALL SGEMLQ( 'R', 'T', M, N, K, AF, M, TQUERY, TSIZE, CF, M,
|
||||||
$ WORKQUERY, -1, INFO)
|
$ WORKQUERY, -1, INFO)
|
||||||
LWORK = MAX( LWORK, INT( WORKQUERY ) )
|
LWORK = MAX( LWORK, INT( WORKQUERY( 1 ) ) )
|
||||||
ALLOCATE ( T( TSIZE ) )
|
ALLOCATE ( T( TSIZE ) )
|
||||||
ALLOCATE ( WORK( LWORK ) )
|
ALLOCATE ( WORK( LWORK ) )
|
||||||
srnamt = 'SGELQ'
|
srnamt = 'SGELQ'
|
||||||
|
|
|
||||||
|
|
@ -74,6 +74,8 @@
|
||||||
*> ZEQ
|
*> ZEQ
|
||||||
*> ZQT
|
*> ZQT
|
||||||
*> ZQX
|
*> ZQX
|
||||||
|
*> ZTS
|
||||||
|
*> ZHH
|
||||||
*> \endverbatim
|
*> \endverbatim
|
||||||
*
|
*
|
||||||
* Parameters:
|
* Parameters:
|
||||||
|
|
@ -108,17 +110,17 @@
|
||||||
*> \author Univ. of Colorado Denver
|
*> \author Univ. of Colorado Denver
|
||||||
*> \author NAG Ltd.
|
*> \author NAG Ltd.
|
||||||
*
|
*
|
||||||
*> \date November 2017
|
*> \date November 2019
|
||||||
*
|
*
|
||||||
*> \ingroup complex16_lin
|
*> \ingroup complex16_lin
|
||||||
*
|
*
|
||||||
* =====================================================================
|
* =====================================================================
|
||||||
PROGRAM ZCHKAA
|
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, --
|
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||||
* November 2017
|
* November 2019
|
||||||
*
|
*
|
||||||
* =====================================================================
|
* =====================================================================
|
||||||
*
|
*
|
||||||
|
|
@ -166,16 +168,16 @@
|
||||||
* .. External Subroutines ..
|
* .. External Subroutines ..
|
||||||
EXTERNAL ALAREQ, ZCHKEQ, ZCHKGB, ZCHKGE, ZCHKGT, ZCHKHE,
|
EXTERNAL ALAREQ, ZCHKEQ, ZCHKGB, ZCHKGE, ZCHKGT, ZCHKHE,
|
||||||
$ ZCHKHE_ROOK, ZCHKHE_RK, ZCHKHE_AA, ZCHKHP,
|
$ ZCHKHE_ROOK, ZCHKHE_RK, ZCHKHE_AA, ZCHKHP,
|
||||||
$ ZCHKLQ, ZCHKPB, ZCHKPO, ZCHKPS, ZCHKPP, ZCHKPT,
|
$ ZCHKLQ, ZCHKUNHR_COL, ZCHKPB, ZCHKPO, ZCHKPS,
|
||||||
$ ZCHKQ3, ZCHKQL, ZCHKQR, ZCHKRQ, ZCHKSP, ZCHKSY,
|
$ ZCHKPP, ZCHKPT, ZCHKQ3, ZCHKQL, ZCHKQR, ZCHKRQ,
|
||||||
$ ZCHKSY_ROOK, ZCHKSY_RK, ZCHKSY_AA, ZCHKTB,
|
$ ZCHKSP, ZCHKSY, ZCHKSY_ROOK, ZCHKSY_RK,
|
||||||
$ ZCHKTP, ZCHKTR, ZCHKTZ, ZDRVGB, ZDRVGE, ZDRVGT,
|
$ ZCHKSY_AA, ZCHKTB, ZCHKTP, ZCHKTR, ZCHKTZ,
|
||||||
$ ZDRVHE, ZDRVHE_ROOK, ZDRVHE_RK, ZDRVHE_AA,
|
$ ZDRVGB, ZDRVGE, ZDRVGT, ZDRVHE, ZDRVHE_ROOK,
|
||||||
$ ZDRVHE_AA_2STAGE, ZDRVHP, ZDRVLS, ZDRVPB,
|
$ ZDRVHE_RK, ZDRVHE_AA, ZDRVHE_AA_2STAGE, ZDRVHP,
|
||||||
$ ZDRVPO, ZDRVPP, ZDRVPT, ZDRVSP, ZDRVSY,
|
$ ZDRVLS, ZDRVPB, ZDRVPO, ZDRVPP, ZDRVPT,
|
||||||
$ ZDRVSY_ROOK, ZDRVSY_RK, ZDRVSY_AA,
|
$ ZDRVSP, ZDRVSY, ZDRVSY_ROOK, ZDRVSY_RK,
|
||||||
$ ZDRVSY_AA_2STAGE, ILAVER, ZCHKQRT, ZCHKQRTP,
|
$ ZDRVSY_AA, ZDRVSY_AA_2STAGE, ILAVER, ZCHKQRT,
|
||||||
$ ZCHKLQT, ZCHKLQTP, ZCHKTSQR
|
$ ZCHKQRTP, ZCHKLQT, ZCHKLQTP, ZCHKTSQR
|
||||||
* ..
|
* ..
|
||||||
* .. Scalars in Common ..
|
* .. Scalars in Common ..
|
||||||
LOGICAL LERR, OK
|
LOGICAL LERR, OK
|
||||||
|
|
@ -679,7 +681,7 @@
|
||||||
*
|
*
|
||||||
* HK: Hermitian indefinite matrices,
|
* HK: Hermitian indefinite matrices,
|
||||||
* with bounded Bunch-Kaufman (rook) pivoting algorithm,
|
* 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
|
NTYPES = 10
|
||||||
CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
|
CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
|
||||||
|
|
@ -839,7 +841,7 @@
|
||||||
*
|
*
|
||||||
* SK: symmetric indefinite matrices,
|
* SK: symmetric indefinite matrices,
|
||||||
* with bounded Bunch-Kaufman (rook) pivoting algorithm,
|
* 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
|
NTYPES = 11
|
||||||
CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
|
CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
|
||||||
|
|
@ -1201,6 +1203,17 @@
|
||||||
ELSE
|
ELSE
|
||||||
WRITE( NOUT, FMT = 9989 )PATH
|
WRITE( NOUT, FMT = 9989 )PATH
|
||||||
END IF
|
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
|
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
|
*> \param[out] E
|
||||||
*> \verbatim
|
*> \verbatim
|
||||||
*> E is COMPLEX*16 array, dimension (NMAX)
|
*> E is COMPLEX*16 array, dimension (NMAX)
|
||||||
|
*> \endverbatim
|
||||||
*>
|
*>
|
||||||
*> \param[out] AINV
|
*> \param[out] AINV
|
||||||
*> \verbatim
|
*> \verbatim
|
||||||
|
|
|
||||||
|
|
@ -237,13 +237,13 @@
|
||||||
DOUBLE PRECISION EPS, NORMA, NORMB, RCOND
|
DOUBLE PRECISION EPS, NORMA, NORMB, RCOND
|
||||||
* ..
|
* ..
|
||||||
* .. Local Arrays ..
|
* .. Local Arrays ..
|
||||||
INTEGER ISEED( 4 ), ISEEDY( 4 ), IWQ
|
INTEGER ISEED( 4 ), ISEEDY( 4 ), IWQ( 1 )
|
||||||
DOUBLE PRECISION RESULT( NTESTS ), RWQ
|
DOUBLE PRECISION RESULT( NTESTS ), RWQ( 1 )
|
||||||
COMPLEX*16 WQ
|
COMPLEX*16 WQ( 1 )
|
||||||
* ..
|
* ..
|
||||||
* .. Allocatable Arrays ..
|
* .. Allocatable Arrays ..
|
||||||
COMPLEX*16, ALLOCATABLE :: WORK (:)
|
COMPLEX*16, ALLOCATABLE :: WORK (:)
|
||||||
DOUBLE PRECISION, ALLOCATABLE :: RWORK (:)
|
DOUBLE PRECISION, ALLOCATABLE :: RWORK (:), WORK2 (:)
|
||||||
INTEGER, ALLOCATABLE :: IWORK (:)
|
INTEGER, ALLOCATABLE :: IWORK (:)
|
||||||
* ..
|
* ..
|
||||||
* .. External Functions ..
|
* .. External Functions ..
|
||||||
|
|
@ -363,32 +363,32 @@
|
||||||
* Compute workspace needed for ZGELS
|
* Compute workspace needed for ZGELS
|
||||||
CALL ZGELS( TRANS, M, N, NRHS, A, LDA,
|
CALL ZGELS( TRANS, M, N, NRHS, A, LDA,
|
||||||
$ B, LDB, WQ, -1, INFO )
|
$ B, LDB, WQ, -1, INFO )
|
||||||
LWORK_ZGELS = INT ( WQ )
|
LWORK_ZGELS = INT ( WQ( 1 ) )
|
||||||
* Compute workspace needed for ZGETSLS
|
* Compute workspace needed for ZGETSLS
|
||||||
CALL ZGETSLS( TRANS, M, N, NRHS, A, LDA,
|
CALL ZGETSLS( TRANS, M, N, NRHS, A, LDA,
|
||||||
$ B, LDB, WQ, -1, INFO )
|
$ B, LDB, WQ, -1, INFO )
|
||||||
LWORK_ZGETSLS = INT( WQ )
|
LWORK_ZGETSLS = INT( WQ( 1 ) )
|
||||||
ENDDO
|
ENDDO
|
||||||
END IF
|
END IF
|
||||||
* Compute workspace needed for ZGELSY
|
* Compute workspace needed for ZGELSY
|
||||||
CALL ZGELSY( M, N, NRHS, A, LDA, B, LDB, IWQ,
|
CALL ZGELSY( M, N, NRHS, A, LDA, B, LDB, IWQ,
|
||||||
$ RCOND, CRANK, WQ, -1, RWORK, INFO )
|
$ RCOND, CRANK, WQ, -1, RWORK, INFO )
|
||||||
LWORK_ZGELSY = INT( WQ )
|
LWORK_ZGELSY = INT( WQ( 1 ) )
|
||||||
LRWORK_ZGELSY = 2*N
|
LRWORK_ZGELSY = 2*N
|
||||||
* Compute workspace needed for ZGELSS
|
* Compute workspace needed for ZGELSS
|
||||||
CALL ZGELSS( M, N, NRHS, A, LDA, B, LDB, S,
|
CALL ZGELSS( M, N, NRHS, A, LDA, B, LDB, S,
|
||||||
$ RCOND, CRANK, WQ, -1 , RWORK,
|
$ RCOND, CRANK, WQ, -1 , RWORK,
|
||||||
$ INFO )
|
$ INFO )
|
||||||
LWORK_ZGELSS = INT( WQ )
|
LWORK_ZGELSS = INT( WQ( 1 ) )
|
||||||
LRWORK_ZGELSS = 5*MNMIN
|
LRWORK_ZGELSS = 5*MNMIN
|
||||||
* Compute workspace needed for ZGELSD
|
* Compute workspace needed for ZGELSD
|
||||||
CALL ZGELSD( M, N, NRHS, A, LDA, B, LDB, S,
|
CALL ZGELSD( M, N, NRHS, A, LDA, B, LDB, S,
|
||||||
$ RCOND, CRANK, WQ, -1, RWQ, IWQ,
|
$ RCOND, CRANK, WQ, -1, RWQ, IWQ,
|
||||||
$ INFO )
|
$ INFO )
|
||||||
LWORK_ZGELSD = INT( WQ )
|
LWORK_ZGELSD = INT( WQ( 1 ) )
|
||||||
LRWORK_ZGELSD = INT( RWQ )
|
LRWORK_ZGELSD = INT( RWQ ( 1 ) )
|
||||||
* Compute LIWORK workspace needed for ZGELSY and ZGELSD
|
* 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
|
* Compute LRWORK workspace needed for ZGELSY, ZGELSS and ZGELSD
|
||||||
LRWORK = MAX( LRWORK, LRWORK_ZGELSY,
|
LRWORK = MAX( LRWORK, LRWORK_ZGELSY,
|
||||||
$ LRWORK_ZGELSS, LRWORK_ZGELSD )
|
$ LRWORK_ZGELSS, LRWORK_ZGELSD )
|
||||||
|
|
@ -406,6 +406,7 @@
|
||||||
LWLSY = LWORK
|
LWLSY = LWORK
|
||||||
*
|
*
|
||||||
ALLOCATE( WORK( LWORK ) )
|
ALLOCATE( WORK( LWORK ) )
|
||||||
|
ALLOCATE( WORK2( 2 * LWORK ) )
|
||||||
ALLOCATE( IWORK( LIWORK ) )
|
ALLOCATE( IWORK( LIWORK ) )
|
||||||
ALLOCATE( RWORK( LRWORK ) )
|
ALLOCATE( RWORK( LRWORK ) )
|
||||||
*
|
*
|
||||||
|
|
@ -596,7 +597,7 @@
|
||||||
$ CALL ZLACPY( 'Full', NROWS, NRHS,
|
$ CALL ZLACPY( 'Full', NROWS, NRHS,
|
||||||
$ COPYB, LDB, C, LDB )
|
$ COPYB, LDB, C, LDB )
|
||||||
CALL ZQRT16( TRANS, M, N, NRHS, COPYA,
|
CALL ZQRT16( TRANS, M, N, NRHS, COPYA,
|
||||||
$ LDA, B, LDB, C, LDB, WORK,
|
$ LDA, B, LDB, C, LDB, WORK2,
|
||||||
$ RESULT( 15 ) )
|
$ RESULT( 15 ) )
|
||||||
*
|
*
|
||||||
IF( ( ITRAN.EQ.1 .AND. M.GE.N ) .OR.
|
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,
|
$ ZHPSV, ZHPSVX, ZPBSV, ZPBSVX, ZPOSV, ZPOSVX,
|
||||||
$ ZPPSV, ZPPSVX, ZPTSV, ZPTSVX, ZSPSV, ZSPSVX,
|
$ ZPPSV, ZPPSVX, ZPTSV, ZPTSVX, ZSPSV, ZSPSVX,
|
||||||
$ ZSYSV, ZSYSV_AA, ZSYSV_RK, ZSYSV_ROOK,
|
$ ZSYSV, ZSYSV_AA, ZSYSV_RK, ZSYSV_ROOK,
|
||||||
$ ZSYSVX, ZSYSV_AA_2STAGE
|
$ ZSYSVX, ZHESV_AA_2STAGE
|
||||||
* ..
|
* ..
|
||||||
* .. Scalars in Common ..
|
* .. Scalars in Common ..
|
||||||
LOGICAL LERR, OK
|
LOGICAL LERR, OK
|
||||||
|
|
@ -721,7 +721,7 @@
|
||||||
*
|
*
|
||||||
ELSE IF( LSAMEN( 2, C2, 'H2' ) ) THEN
|
ELSE IF( LSAMEN( 2, C2, 'H2' ) ) THEN
|
||||||
*
|
*
|
||||||
* CHESV_AASEN_2STAGE
|
* ZHESV_AASEN_2STAGE
|
||||||
*
|
*
|
||||||
SRNAMT = 'ZHESV_AA_2STAGE'
|
SRNAMT = 'ZHESV_AA_2STAGE'
|
||||||
INFOT = 1
|
INFOT = 1
|
||||||
|
|
@ -741,7 +741,7 @@
|
||||||
$ W, 1, INFO )
|
$ W, 1, INFO )
|
||||||
CALL CHKXER( 'ZHESV_AA_2STAGE', INFOT, NOUT, LERR, OK )
|
CALL CHKXER( 'ZHESV_AA_2STAGE', INFOT, NOUT, LERR, OK )
|
||||||
INFOT = 11
|
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 )
|
$ W, 1, INFO )
|
||||||
CALL CHKXER( 'ZHESV_AA_2STAGE', INFOT, NOUT, LERR, OK )
|
CALL CHKXER( 'ZHESV_AA_2STAGE', INFOT, NOUT, LERR, OK )
|
||||||
INFOT = 7
|
INFOT = 7
|
||||||
|
|
@ -749,6 +749,36 @@
|
||||||
$ W, 1, INFO )
|
$ W, 1, INFO )
|
||||||
CALL CHKXER( 'ZHESV_AA_2STAGE', INFOT, NOUT, LERR, OK )
|
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
|
ELSE IF( LSAMEN( 2, C2, 'HP' ) ) THEN
|
||||||
*
|
*
|
||||||
* ZHPSV
|
* ZHPSV
|
||||||
|
|
|
||||||
|
|
@ -164,7 +164,7 @@
|
||||||
INTEGER NMAX_EXACT, NMAX_APPROX, SIZE_D
|
INTEGER NMAX_EXACT, NMAX_APPROX, SIZE_D
|
||||||
PARAMETER (NMAX_EXACT = 6, NMAX_APPROX = 11, SIZE_D = 8)
|
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)
|
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 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)/
|
DATA D2 /(-1,0),(0,-1),(-1,1),(0,1),(1,0),(-1,-1),(1,-1),(1,1)/
|
||||||
|
|
|
||||||
|
|
@ -114,7 +114,7 @@
|
||||||
* ..
|
* ..
|
||||||
* .. Local Arrays ..
|
* .. Local Arrays ..
|
||||||
INTEGER ISEED( 4 )
|
INTEGER ISEED( 4 )
|
||||||
COMPLEX*16 TQUERY( 5 ), WORKQUERY
|
COMPLEX*16 TQUERY( 5 ), WORKQUERY( 1 )
|
||||||
* ..
|
* ..
|
||||||
* .. External Functions ..
|
* .. External Functions ..
|
||||||
DOUBLE PRECISION DLAMCH, ZLANGE, ZLANSY
|
DOUBLE PRECISION DLAMCH, ZLANGE, ZLANSY
|
||||||
|
|
@ -173,22 +173,22 @@
|
||||||
*
|
*
|
||||||
CALL ZGEQR( M, N, AF, M, TQUERY, -1, WORKQUERY, -1, INFO )
|
CALL ZGEQR( M, N, AF, M, TQUERY, -1, WORKQUERY, -1, INFO )
|
||||||
TSIZE = INT( TQUERY( 1 ) )
|
TSIZE = INT( TQUERY( 1 ) )
|
||||||
LWORK = INT( WORKQUERY )
|
LWORK = INT( WORKQUERY( 1 ) )
|
||||||
CALL ZGEMQR( 'L', 'N', M, M, K, AF, M, TQUERY, TSIZE, CF, M,
|
CALL ZGEMQR( 'L', 'N', M, M, K, AF, M, TQUERY, TSIZE, CF, M,
|
||||||
$ WORKQUERY, -1, INFO)
|
$ 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,
|
CALL ZGEMQR( 'L', 'N', M, N, K, AF, M, TQUERY, TSIZE, CF, M,
|
||||||
$ WORKQUERY, -1, INFO)
|
$ 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,
|
CALL ZGEMQR( 'L', 'C', M, N, K, AF, M, TQUERY, TSIZE, CF, M,
|
||||||
$ WORKQUERY, -1, INFO)
|
$ 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,
|
CALL ZGEMQR( 'R', 'N', N, M, K, AF, M, TQUERY, TSIZE, DF, N,
|
||||||
$ WORKQUERY, -1, INFO)
|
$ 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,
|
CALL ZGEMQR( 'R', 'C', N, M, K, AF, M, TQUERY, TSIZE, DF, N,
|
||||||
$ WORKQUERY, -1, INFO)
|
$ WORKQUERY, -1, INFO)
|
||||||
LWORK = MAX( LWORK, INT( WORKQUERY ) )
|
LWORK = MAX( LWORK, INT( WORKQUERY( 1 ) ) )
|
||||||
ALLOCATE ( T( TSIZE ) )
|
ALLOCATE ( T( TSIZE ) )
|
||||||
ALLOCATE ( WORK( LWORK ) )
|
ALLOCATE ( WORK( LWORK ) )
|
||||||
srnamt = 'ZGEQR'
|
srnamt = 'ZGEQR'
|
||||||
|
|
@ -316,22 +316,22 @@
|
||||||
ELSE
|
ELSE
|
||||||
CALL ZGELQ( M, N, AF, M, TQUERY, -1, WORKQUERY, -1, INFO )
|
CALL ZGELQ( M, N, AF, M, TQUERY, -1, WORKQUERY, -1, INFO )
|
||||||
TSIZE = INT( TQUERY( 1 ) )
|
TSIZE = INT( TQUERY( 1 ) )
|
||||||
LWORK = INT( WORKQUERY )
|
LWORK = INT( WORKQUERY( 1 ) )
|
||||||
CALL ZGEMLQ( 'R', 'N', N, N, K, AF, M, TQUERY, TSIZE, Q, N,
|
CALL ZGEMLQ( 'R', 'N', N, N, K, AF, M, TQUERY, TSIZE, Q, N,
|
||||||
$ WORKQUERY, -1, INFO )
|
$ 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,
|
CALL ZGEMLQ( 'L', 'N', N, M, K, AF, M, TQUERY, TSIZE, DF, N,
|
||||||
$ WORKQUERY, -1, INFO)
|
$ 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,
|
CALL ZGEMLQ( 'L', 'C', N, M, K, AF, M, TQUERY, TSIZE, DF, N,
|
||||||
$ WORKQUERY, -1, INFO)
|
$ 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,
|
CALL ZGEMLQ( 'R', 'N', M, N, K, AF, M, TQUERY, TSIZE, CF, M,
|
||||||
$ WORKQUERY, -1, INFO)
|
$ 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,
|
CALL ZGEMLQ( 'R', 'C', M, N, K, AF, M, TQUERY, TSIZE, CF, M,
|
||||||
$ WORKQUERY, -1, INFO)
|
$ WORKQUERY, -1, INFO)
|
||||||
LWORK = MAX( LWORK, INT( WORKQUERY ) )
|
LWORK = MAX( LWORK, INT( WORKQUERY( 1 ) ) )
|
||||||
ALLOCATE ( T( TSIZE ) )
|
ALLOCATE ( T( TSIZE ) )
|
||||||
ALLOCATE ( WORK( LWORK ) )
|
ALLOCATE ( WORK( LWORK ) )
|
||||||
srnamt = 'ZGELQ'
|
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