OSchip
/
OpenBLAS
Not watched
1
0
Fork 0
Code
Releases 66 Wiki evaluate Activity
Issues 0 Pull Requests 0 Datasets Model Cloudbrain HPC
Browse Source

Update LAPACK to 3.9.0

pull/2353/head
Martin Kroeker GitHub 6 years ago
parent
4f0b98d46d
commit
ab74361a0c
No known key found for this signature in database GPG Key ID: 4AEE18F83AFDEB23
34 changed files with 3454 additions and 196 deletions
Unified View
Diff Options
Show Stats Download Patch File Download Diff File
  1. +8
    -4
      lapack-netlib/TESTING/LIN/CMakeLists.txt
  2. +38
    -37
      lapack-netlib/TESTING/LIN/Makefile
  3. +27
    -13
      lapack-netlib/TESTING/LIN/cchkaa.f
  4. +239
    -0
      lapack-netlib/TESTING/LIN/cchkunhr_col.f
  5. +13
    -12
      lapack-netlib/TESTING/LIN/cdrvls.f
  6. +2
    -1
      lapack-netlib/TESTING/LIN/cdrvsy_rk.f
  7. +164
    -0
      lapack-netlib/TESTING/LIN/cerrunhr_col.f
  8. +2
    -2
      lapack-netlib/TESTING/LIN/cerrvx.f
  9. +1
    -1
      lapack-netlib/TESTING/LIN/clahilb.f
  10. +13
    -13
      lapack-netlib/TESTING/LIN/ctsqr01.f
  11. +390
    -0
      lapack-netlib/TESTING/LIN/cunhr_col01.f
  12. +27
    -12
      lapack-netlib/TESTING/LIN/dchkaa.f
  13. +239
    -0
      lapack-netlib/TESTING/LIN/dchkorhr_col.f
  14. +8
    -8
      lapack-netlib/TESTING/LIN/ddrvls.f
  15. +164
    -0
      lapack-netlib/TESTING/LIN/derrorhr_col.f
  16. +1
    -1
      lapack-netlib/TESTING/LIN/derrvx.f
  17. +386
    -0
      lapack-netlib/TESTING/LIN/dorhr_col01.f
  18. +13
    -13
      lapack-netlib/TESTING/LIN/dtsqr01.f
  19. +24
    -11
      lapack-netlib/TESTING/LIN/schkaa.f
  20. +239
    -0
      lapack-netlib/TESTING/LIN/schkorhr_col.f
  21. +10
    -10
      lapack-netlib/TESTING/LIN/sdrvls.f
  22. +164
    -0
      lapack-netlib/TESTING/LIN/serrorhr_col.f
  23. +1
    -1
      lapack-netlib/TESTING/LIN/serrvx.f
  24. +386
    -0
      lapack-netlib/TESTING/LIN/sorhr_col01.f
  25. +13
    -13
      lapack-netlib/TESTING/LIN/stsqr01.f
  26. +28
    -15
      lapack-netlib/TESTING/LIN/zchkaa.f
  27. +239
    -0
      lapack-netlib/TESTING/LIN/zchkunhr_col.f
  28. +1
    -0
      lapack-netlib/TESTING/LIN/zdrvhe_rk.f
  29. +13
    -12
      lapack-netlib/TESTING/LIN/zdrvls.f
  30. +164
    -0
      lapack-netlib/TESTING/LIN/zerrunhr_col.f
  31. +33
    -3
      lapack-netlib/TESTING/LIN/zerrvx.f
  32. +1
    -1
      lapack-netlib/TESTING/LIN/zlahilb.f
  33. +13
    -13
      lapack-netlib/TESTING/LIN/ztsqr01.f
  34. +390
    -0
      lapack-netlib/TESTING/LIN/zunhr_col01.f

+ 8
- 4
lapack-netlib/TESTING/LIN/CMakeLists.txt View File

@@ -39,7 +39,8 @@ set(SLINTST schkaa.f
strt02.f strt03.f strt05.f strt06.f 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


+ 38
- 37
lapack-netlib/TESTING/LIN/Makefile View File

@@ -1,5 +1,3 @@
include ../../make.inc

####################################################################### #######################################################################
# This makefile creates the test programs for the linear equation # 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)),)
LAPACKLIB := $(VARLIB) ../../$(LAPACKLIB)
endif

TOPSRCDIR = ../..
include $(TOPSRCDIR)/make.inc


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)
$(LOADER) $(LOADOPTS) -o $@ $^
xlintsts: $(ALINTST) $(SLINTST) $(SCLNTST) $(TMGLIB) $(VARLIB) $(LAPACKLIB) $(XBLASLIB) $(BLASLIB)
$(FC) $(FFLAGS) $(LDFLAGS) -o $@ $^


xlintstc: $(ALINTST) $(CLINTST) $(SCLNTST) ../../$(TMGLIB) ../../$(LAPACKLIB) $(XBLASLIB) $(BLASLIB)
$(LOADER) $(LOADOPTS) -o $@ $^
xlintstc: $(ALINTST) $(CLINTST) $(SCLNTST) $(TMGLIB) $(VARLIB) $(LAPACKLIB) $(XBLASLIB) $(BLASLIB)
$(FC) $(FFLAGS) $(LDFLAGS) -o $@ $^


xlintstd: $(ALINTST) $(DLINTST) $(DZLNTST) ../../$(TMGLIB) ../../$(LAPACKLIB) $(XBLASLIB) $(BLASLIB)
$(LOADER) $(LOADOPTS) -o $@ $^
xlintstd: $(ALINTST) $(DLINTST) $(DZLNTST) $(TMGLIB) $(VARLIB) $(LAPACKLIB) $(XBLASLIB) $(BLASLIB)
$(FC) $(FFLAGS) $(LDFLAGS) -o $@ $^


xlintstz: $(ALINTST) $(ZLINTST) $(DZLNTST) ../../$(TMGLIB) ../../$(LAPACKLIB) $(XBLASLIB) $(BLASLIB)
$(LOADER) $(LOADOPTS) -o $@ $^
xlintstz: $(ALINTST) $(ZLINTST) $(DZLNTST) $(TMGLIB) $(VARLIB) $(LAPACKLIB) $(XBLASLIB) $(BLASLIB)
$(FC) $(FFLAGS) $(LDFLAGS) -o $@ $^


xlintstds: $(DSLINTST) ../../$(TMGLIB) ../../$(LAPACKLIB) $(BLASLIB)
$(LOADER) $(LOADOPTS) -o $@ $^
xlintstds: $(DSLINTST) $(TMGLIB) $(VARLIB) $(LAPACKLIB) $(BLASLIB)
$(FC) $(FFLAGS) $(LDFLAGS) -o $@ $^


xlintstzc: $(ZCLINTST) ../../$(TMGLIB) ../../$(LAPACKLIB) $(BLASLIB)
$(LOADER) $(LOADOPTS) -o $@ $^
xlintstzc: $(ZCLINTST) $(TMGLIB) $(VARLIB) $(LAPACKLIB) $(BLASLIB)
$(FC) $(FFLAGS) $(LDFLAGS) -o $@ $^


xlintstrfs: $(SLINTSTRFP) ../../$(TMGLIB) ../../$(LAPACKLIB) $(BLASLIB)
$(LOADER) $(LOADOPTS) -o $@ $^
xlintstrfs: $(SLINTSTRFP) $(TMGLIB) $(VARLIB) $(LAPACKLIB) $(BLASLIB)
$(FC) $(FFLAGS) $(LDFLAGS) -o $@ $^


xlintstrfd: $(DLINTSTRFP) ../../$(TMGLIB) ../../$(LAPACKLIB) $(BLASLIB)
$(LOADER) $(LOADOPTS) -o $@ $^
xlintstrfd: $(DLINTSTRFP) $(TMGLIB) $(VARLIB) $(LAPACKLIB) $(BLASLIB)
$(FC) $(FFLAGS) $(LDFLAGS) -o $@ $^


xlintstrfc: $(CLINTSTRFP) ../../$(TMGLIB) ../../$(LAPACKLIB) $(BLASLIB)
$(LOADER) $(LOADOPTS) -o $@ $^
xlintstrfc: $(CLINTSTRFP) $(TMGLIB) $(VARLIB) $(LAPACKLIB) $(BLASLIB)
$(FC) $(FFLAGS) $(LDFLAGS) -o $@ $^


xlintstrfz: $(ZLINTSTRFP) ../../$(TMGLIB) ../../$(LAPACKLIB) $(BLASLIB)
$(LOADER) $(LOADOPTS) -o $@ $^
xlintstrfz: $(ZLINTSTRFP) $(TMGLIB) $(VARLIB) $(LAPACKLIB) $(BLASLIB)
$(FC) $(FFLAGS) $(LDFLAGS) -o $@ $^


$(ALINTST): $(FRC) $(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 $@ $<

.f.o:
$(FORTRAN) $(OPTS) -c -o $@ $<
$(FC) $(FFLAGS_DRV) -c -o $@ $<


.NOTPARALLEL: .NOTPARALLEL:

+ 27
- 13
lapack-netlib/TESTING/LIN/cchkaa.f View File

@@ -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,
$ CCHKPB,CCHKPO, CCHKPS, CCHKPP, CCHKPT, CCHKQ3,
$ CCHKQL, CCHKQR, CCHKRQ, CCHKSP, CCHKSY,
$ CCHKSY_ROOK, CCHKSY_RK, CCHKSY_AA, CCHKTB,
$ CCHKTP, CCHKTR, CCHKTZ, CDRVGB, CDRVGE, CDRVGT,
$ CDRVHE, CDRVHE_ROOK, CDRVHE_RK, CDRVHE_AA,
$ CDRVHP, CDRVLS, CDRVPB, CDRVPO, CDRVPP, CDRVPT,
$ CDRVSP, CDRVSY, CDRVSY_ROOK, CDRVSY_RK,
$ CDRVSY_AA, ILAVER, CCHKQRT, CCHKQRTP
$ CCHKHE_ROOK, CCHKHE_RK, CCHKHE_AA, CCHKHP,
$ CCHKLQ, CCHKUNHR_COL, CCHKPB, CCHKPO, CCHKPS,
$ CCHKPP, CCHKPT, CCHKQ3, CCHKQL, CCHKQR, CCHKRQ,
$ CCHKSP, CCHKSY, CCHKSY_ROOK, CCHKSY_RK,
$ CCHKSY_AA, CCHKTB, CCHKTP, CCHKTR, CCHKTZ,
$ CDRVGB, CDRVGE, CDRVGT, CDRVHE, CDRVHE_ROOK,
$ CDRVHE_RK, CDRVHE_AA, CDRVHP, CDRVLS, CDRVPB,
$ CDRVPO, CDRVPP, CDRVPT, CDRVSP, CDRVSY,
$ CDRVSY_ROOK, CDRVSY_RK, CDRVSY_AA, ILAVER,
$ CCHKQRT, CCHKQRTP
* .. * ..
* .. Scalars in Common .. * .. 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
* *


+ 239
- 0
lapack-netlib/TESTING/LIN/cchkunhr_col.f View File

@@ -0,0 +1,239 @@
*> \brief \b CCHKUNHR_COL
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE CCHKUNHR_COL( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
* NBVAL, NOUT )
*
* .. Scalar Arguments ..
* LOGICAL TSTERR
* INTEGER NM, NN, NNB, NOUT
* REAL THRESH
* ..
* .. Array Arguments ..
* INTEGER MVAL( * ), NBVAL( * ), NVAL( * )
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> CCHKUNHR_COL tests CUNHR_COL using CLATSQR and CGEMQRT. Therefore, CLATSQR
*> (used in CGEQR) and CGEMQRT (used in CGEMQR) have to be tested
*> before this test.
*>
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] THRESH
*> \verbatim
*> THRESH is REAL
*> The threshold value for the test ratios. A result is
*> included in the output file if RESULT >= THRESH. To have
*> every test ratio printed, use THRESH = 0.
*> \endverbatim
*>
*> \param[in] TSTERR
*> \verbatim
*> TSTERR is LOGICAL
*> Flag that indicates whether error exits are to be tested.
*> \endverbatim
*>
*> \param[in] NM
*> \verbatim
*> NM is INTEGER
*> The number of values of M contained in the vector MVAL.
*> \endverbatim
*>
*> \param[in] MVAL
*> \verbatim
*> MVAL is INTEGER array, dimension (NM)
*> The values of the matrix row dimension M.
*> \endverbatim
*>
*> \param[in] NN
*> \verbatim
*> NN is INTEGER
*> The number of values of N contained in the vector NVAL.
*> \endverbatim
*>
*> \param[in] NVAL
*> \verbatim
*> NVAL is INTEGER array, dimension (NN)
*> The values of the matrix column dimension N.
*> \endverbatim
*>
*> \param[in] NNB
*> \verbatim
*> NNB is INTEGER
*> The number of values of NB contained in the vector NBVAL.
*> \endverbatim
*>
*> \param[in] NBVAL
*> \verbatim
*> NBVAL is INTEGER array, dimension (NBVAL)
*> The values of the blocksize NB.
*> \endverbatim
*>
*> \param[in] NOUT
*> \verbatim
*> NOUT is INTEGER
*> The unit number for output.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2019
*
*> \ingroup complex_lin
*
* =====================================================================
SUBROUTINE CCHKUNHR_COL( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
$ NBVAL, NOUT )
IMPLICIT NONE
*
* -- LAPACK test routine (version 3.7.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* December 2016
*
* .. Scalar Arguments ..
LOGICAL TSTERR
INTEGER NM, NN, NNB, NOUT
REAL THRESH
* ..
* .. Array Arguments ..
INTEGER MVAL( * ), NBVAL( * ), NVAL( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
INTEGER NTESTS
PARAMETER ( NTESTS = 6 )
* ..
* .. Local Scalars ..
CHARACTER(LEN=3) PATH
INTEGER I, IMB1, INB1, INB2, J, T, M, N, MB1, NB1,
$ NB2, NFAIL, NERRS, NRUN
*
* .. Local Arrays ..
REAL RESULT( NTESTS )
* ..
* .. External Subroutines ..
EXTERNAL ALAHD, ALASUM, CERRUNHR_COL, CUNHR_COL01
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER(LEN=32) SRNAMT
INTEGER INFOT, NUNIT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, NUNIT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Executable Statements ..
*
* Initialize constants
*
PATH( 1: 1 ) = 'C'
PATH( 2: 3 ) = 'HH'
NRUN = 0
NFAIL = 0
NERRS = 0
*
* Test the error exits
*
IF( TSTERR ) CALL CERRUNHR_COL( PATH, NOUT )
INFOT = 0
*
* Do for each value of M in MVAL.
*
DO I = 1, NM
M = MVAL( I )
*
* Do for each value of N in NVAL.
*
DO J = 1, NN
N = NVAL( J )
*
* Only for M >= N
*
IF ( MIN( M, N ).GT.0 .AND. M.GE.N ) THEN
*
* Do for each possible value of MB1
*
DO IMB1 = 1, NNB
MB1 = NBVAL( IMB1 )
*
* Only for MB1 > N
*
IF ( MB1.GT.N ) THEN
*
* Do for each possible value of NB1
*
DO INB1 = 1, NNB
NB1 = NBVAL( INB1 )
*
* Do for each possible value of NB2
*
DO INB2 = 1, NNB
NB2 = NBVAL( INB2 )
*
IF( NB1.GT.0 .AND. NB2.GT.0 ) THEN
*
* Test CUNHR_COL
*
CALL CUNHR_COL01( M, N, MB1, NB1, NB2,
$ RESULT )
*
* Print information about the tests that did
* not pass the threshold.
*
DO T = 1, NTESTS
IF( RESULT( T ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9999 ) M, N, MB1,
$ NB1, NB2, T, RESULT( T )
NFAIL = NFAIL + 1
END IF
END DO
NRUN = NRUN + NTESTS
END IF
END DO
END DO
END IF
END DO
END IF
END DO
END DO
*
* Print a summary of the results.
*
CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
*
9999 FORMAT( 'M=', I5, ', N=', I5, ', MB1=', I5,
$ ', NB1=', I5, ', NB2=', I5,' test(', I2, ')=', G12.5 )
RETURN
*
* End of CCHKUNHR_COL
*
END

+ 13
- 12
lapack-netlib/TESTING/LIN/cdrvls.f View File

@@ -237,13 +237,13 @@
REAL EPS, NORMA, NORMB, RCOND REAL EPS, NORMA, NORMB, RCOND
* .. * ..
* .. Local Arrays .. * .. Local Arrays ..
INTEGER ISEED( 4 ), ISEEDY( 4 ), IWQ
REAL RESULT( NTESTS ), RWQ
COMPLEX WQ
INTEGER ISEED( 4 ), ISEEDY( 4 ), IWQ( 1 )
REAL RESULT( NTESTS ), RWQ( 1 )
COMPLEX WQ( 1 )
* .. * ..
* .. Allocatable Arrays .. * .. 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 )
LRWORK_CGELSD = INT( RWQ )
LWORK_CGELSD = INT( WQ( 1 ) )
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.


+ 2
- 1
lapack-netlib/TESTING/LIN/cdrvsy_rk.f View File

@@ -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


+ 164
- 0
lapack-netlib/TESTING/LIN/cerrunhr_col.f View File

@@ -0,0 +1,164 @@
*> \brief \b CERRUNHR_COL
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE CERRUNHR_COL( PATH, NUNIT )
*
* .. Scalar Arguments ..
* CHARACTER*3 PATH
* INTEGER NUNIT
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> CERRUNHR_COL tests the error exits for CUNHR_COL that does
*> Householder reconstruction from the ouput of tall-skinny
*> factorization CLATSQR.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] PATH
*> \verbatim
*> PATH is CHARACTER*3
*> The LAPACK path name for the routines to be tested.
*> \endverbatim
*>
*> \param[in] NUNIT
*> \verbatim
*> NUNIT is INTEGER
*> The unit number for output.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2019
*
*> \ingroup complex_lin
*
* =====================================================================
SUBROUTINE CERRUNHR_COL( PATH, NUNIT )
IMPLICIT NONE
*
* -- LAPACK test routine (version 3.9.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2019
*
* .. Scalar Arguments ..
CHARACTER(LEN=3) PATH
INTEGER NUNIT
* ..
*
* =====================================================================
*
* .. Parameters ..
INTEGER NMAX
PARAMETER ( NMAX = 2 )
* ..
* .. Local Scalars ..
INTEGER I, INFO, J
* ..
* .. Local Arrays ..
COMPLEX A( NMAX, NMAX ), T( NMAX, NMAX ), D(NMAX)
* ..
* .. External Subroutines ..
EXTERNAL ALAESM, CHKXER, CUNHR_COL
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER(LEN=32) SRNAMT
INTEGER INFOT, NOUT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, NOUT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Intrinsic Functions ..
INTRINSIC REAL, CMPLX
* ..
* .. Executable Statements ..
*
NOUT = NUNIT
WRITE( NOUT, FMT = * )
*
* Set the variables to innocuous values.
*
DO J = 1, NMAX
DO I = 1, NMAX
A( I, J ) = CMPLX( 1.E+0 / REAL( I+J ) )
T( I, J ) = CMPLX( 1.E+0 / REAL( I+J ) )
END DO
D( J ) = ( 0.E+0, 0.E+0 )
END DO
OK = .TRUE.
*
* Error exits for Householder reconstruction
*
* CUNHR_COL
*
SRNAMT = 'CUNHR_COL'
*
INFOT = 1
CALL CUNHR_COL( -1, 0, 1, A, 1, T, 1, D, INFO )
CALL CHKXER( 'CUNHR_COL', INFOT, NOUT, LERR, OK )
*
INFOT = 2
CALL CUNHR_COL( 0, -1, 1, A, 1, T, 1, D, INFO )
CALL CHKXER( 'CUNHR_COL', INFOT, NOUT, LERR, OK )
CALL CUNHR_COL( 1, 2, 1, A, 1, T, 1, D, INFO )
CALL CHKXER( 'CUNHR_COL', INFOT, NOUT, LERR, OK )
*
INFOT = 3
CALL CUNHR_COL( 0, 0, -1, A, 1, T, 1, D, INFO )
CALL CHKXER( 'CUNHR_COL', INFOT, NOUT, LERR, OK )
*
CALL CUNHR_COL( 0, 0, 0, A, 1, T, 1, D, INFO )
CALL CHKXER( 'CUNHR_COL', INFOT, NOUT, LERR, OK )
*
INFOT = 5
CALL CUNHR_COL( 0, 0, 1, A, -1, T, 1, D, INFO )
CALL CHKXER( 'CUNHR_COL', INFOT, NOUT, LERR, OK )
*
CALL CUNHR_COL( 0, 0, 1, A, 0, T, 1, D, INFO )
CALL CHKXER( 'CUNHR_COL', INFOT, NOUT, LERR, OK )
*
CALL CUNHR_COL( 2, 0, 1, A, 1, T, 1, D, INFO )
CALL CHKXER( 'CUNHR_COL', INFOT, NOUT, LERR, OK )
*
INFOT = 7
CALL CUNHR_COL( 0, 0, 1, A, 1, T, -1, D, INFO )
CALL CHKXER( 'CUNHR_COL', INFOT, NOUT, LERR, OK )
*
CALL CUNHR_COL( 0, 0, 1, A, 1, T, 0, D, INFO )
CALL CHKXER( 'CUNHR_COL', INFOT, NOUT, LERR, OK )
*
CALL CUNHR_COL( 4, 3, 2, A, 4, T, 1, D, INFO )
CALL CHKXER( 'CUNHR_COL', INFOT, NOUT, LERR, OK )
*
* Print a summary line.
*
CALL ALAESM( PATH, OK, NOUT )
*
RETURN
*
* End of CERRUNHR_COL
*
END

+ 2
- 2
lapack-netlib/TESTING/LIN/cerrvx.f View File

@@ -739,7 +739,7 @@
$ W, 1, INFO ) $ 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


+ 1
- 1
lapack-netlib/TESTING/LIN/clahilb.f View File

@@ -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)/


+ 13
- 13
lapack-netlib/TESTING/LIN/ctsqr01.f View File

@@ -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'


+ 390
- 0
lapack-netlib/TESTING/LIN/cunhr_col01.f View File

@@ -0,0 +1,390 @@
*> \brief \b CUNHR_COL01
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE CUNHR_COL01( M, N, MB1, NB1, NB2, RESULT )
*
* .. Scalar Arguments ..
* INTEGER M, N, MB1, NB1, NB2
* .. Return values ..
* REAL RESULT(6)
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> CUNHR_COL01 tests CUNHR_COL using CLATSQR, CGEMQRT and CUNGTSQR.
*> Therefore, CLATSQR (part of CGEQR), CGEMQRT (part CGEMQR), CUNGTSQR
*> have to be tested before this test.
*>
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> Number of rows in test matrix.
*> \endverbatim
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> Number of columns in test matrix.
*> \endverbatim
*> \param[in] MB1
*> \verbatim
*> MB1 is INTEGER
*> Number of row in row block in an input test matrix.
*> \endverbatim
*>
*> \param[in] NB1
*> \verbatim
*> NB1 is INTEGER
*> Number of columns in column block an input test matrix.
*> \endverbatim
*>
*> \param[in] NB2
*> \verbatim
*> NB2 is INTEGER
*> Number of columns in column block in an output test matrix.
*> \endverbatim
*>
*> \param[out] RESULT
*> \verbatim
*> RESULT is REAL array, dimension (6)
*> Results of each of the six tests below.
*> ( C is a M-by-N random matrix, D is a N-by-M random matrix )
*>
*> RESULT(1) = | A - Q * R | / (eps * m * |A|)
*> RESULT(2) = | I - (Q**H) * Q | / (eps * m )
*> RESULT(3) = | Q * C - Q * C | / (eps * m * |C|)
*> RESULT(4) = | (Q**H) * C - (Q**H) * C | / (eps * m * |C|)
*> RESULT(5) = | (D * Q) - D * Q | / (eps * m * |D|)
*> RESULT(6) = | D * (Q**H) - D * (Q**H) | / (eps * m * |D|)
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2019
*
*> \ingroup complex16_lin
*
* =====================================================================
SUBROUTINE CUNHR_COL01( M, N, MB1, NB1, NB2, RESULT )
IMPLICIT NONE
*
* -- LAPACK test routine (version 3.9.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2019
*
* .. Scalar Arguments ..
INTEGER M, N, MB1, NB1, NB2
* .. Return values ..
REAL RESULT(6)
*
* =====================================================================
*
* ..
* .. Local allocatable arrays
COMPLEX, ALLOCATABLE :: A(:,:), AF(:,:), Q(:,:), R(:,:),
$ WORK( : ), T1(:,:), T2(:,:), DIAG(:),
$ C(:,:), CF(:,:), D(:,:), DF(:,:)
REAL, ALLOCATABLE :: RWORK(:)
*
* .. Parameters ..
REAL ZERO
PARAMETER ( ZERO = 0.0E+0 )
COMPLEX CONE, CZERO
PARAMETER ( CONE = ( 1.0E+0, 0.0E+0 ),
$ CZERO = ( 0.0E+0, 0.0E+0 ) )
* ..
* .. Local Scalars ..
LOGICAL TESTZEROS
INTEGER INFO, I, J, K, L, LWORK, NB1_UB, NB2_UB, NRB
REAL ANORM, EPS, RESID, CNORM, DNORM
* ..
* .. Local Arrays ..
INTEGER ISEED( 4 )
COMPLEX WORKQUERY( 1 )
* ..
* .. External Functions ..
REAL SLAMCH, CLANGE, CLANSY
EXTERNAL SLAMCH, CLANGE, CLANSY
* ..
* .. External Subroutines ..
EXTERNAL CLACPY, CLARNV, CLASET, CLATSQR, CUNHR_COL,
$ CUNGTSQR, CSCAL, CGEMM, CGEMQRT, CHERK
* ..
* .. Intrinsic Functions ..
INTRINSIC CEILING, REAL, MAX, MIN
* ..
* .. Scalars in Common ..
CHARACTER(LEN=32) SRNAMT
* ..
* .. Common blocks ..
COMMON / SRMNAMC / SRNAMT
* ..
* .. Data statements ..
DATA ISEED / 1988, 1989, 1990, 1991 /
*
* TEST MATRICES WITH HALF OF MATRIX BEING ZEROS
*
TESTZEROS = .FALSE.
*
EPS = SLAMCH( 'Epsilon' )
K = MIN( M, N )
L = MAX( M, N, 1)
*
* Dynamically allocate local arrays
*
ALLOCATE ( A(M,N), AF(M,N), Q(L,L), R(M,L), RWORK(L),
$ C(M,N), CF(M,N),
$ D(N,M), DF(N,M) )
*
* Put random numbers into A and copy to AF
*
DO J = 1, N
CALL CLARNV( 2, ISEED, M, A( 1, J ) )
END DO
IF( TESTZEROS ) THEN
IF( M.GE.4 ) THEN
DO J = 1, N
CALL CLARNV( 2, ISEED, M/2, A( M/4, J ) )
END DO
END IF
END IF
CALL CLACPY( 'Full', M, N, A, M, AF, M )
*
* Number of row blocks in CLATSQR
*
NRB = MAX( 1, CEILING( REAL( M - N ) / REAL( MB1 - N ) ) )
*
ALLOCATE ( T1( NB1, N * NRB ) )
ALLOCATE ( T2( NB2, N ) )
ALLOCATE ( DIAG( N ) )
*
* Begin determine LWORK for the array WORK and allocate memory.
*
* CLATSQR requires NB1 to be bounded by N.
*
NB1_UB = MIN( NB1, N)
*
* CGEMQRT requires NB2 to be bounded by N.
*
NB2_UB = MIN( NB2, N)
*
CALL CLATSQR( M, N, MB1, NB1_UB, AF, M, T1, NB1,
$ WORKQUERY, -1, INFO )
LWORK = INT( WORKQUERY( 1 ) )
CALL CUNGTSQR( M, N, MB1, NB1, AF, M, T1, NB1, WORKQUERY, -1,
$ INFO )

LWORK = MAX( LWORK, INT( WORKQUERY( 1 ) ) )
*
* In CGEMQRT, WORK is N*NB2_UB if SIDE = 'L',
* or M*NB2_UB if SIDE = 'R'.
*
LWORK = MAX( LWORK, NB2_UB * N, NB2_UB * M )
*
ALLOCATE ( WORK( LWORK ) )
*
* End allocate memory for WORK.
*
*
* Begin Householder reconstruction routines
*
* Factor the matrix A in the array AF.
*
SRNAMT = 'CLATSQR'
CALL CLATSQR( M, N, MB1, NB1_UB, AF, M, T1, NB1, WORK, LWORK,
$ INFO )
*
* Copy the factor R into the array R.
*
SRNAMT = 'CLACPY'
CALL CLACPY( 'U', M, N, AF, M, R, M )
*
* Reconstruct the orthogonal matrix Q.
*
SRNAMT = 'CUNGTSQR'
CALL CUNGTSQR( M, N, MB1, NB1, AF, M, T1, NB1, WORK, LWORK,
$ INFO )
*
* Perform the Householder reconstruction, the result is stored
* the arrays AF and T2.
*
SRNAMT = 'CUNHR_COL'
CALL CUNHR_COL( M, N, NB2, AF, M, T2, NB2, DIAG, INFO )
*
* Compute the factor R_hr corresponding to the Householder
* reconstructed Q_hr and place it in the upper triangle of AF to
* match the Q storage format in CGEQRT. R_hr = R_tsqr * S,
* this means changing the sign of I-th row of the matrix R_tsqr
* according to sign of of I-th diagonal element DIAG(I) of the
* matrix S.
*
SRNAMT = 'CLACPY'
CALL CLACPY( 'U', M, N, R, M, AF, M )
*
DO I = 1, N
IF( DIAG( I ).EQ.-CONE ) THEN
CALL CSCAL( N+1-I, -CONE, AF( I, I ), M )
END IF
END DO
*
* End Householder reconstruction routines.
*
*
* Generate the m-by-m matrix Q
*
CALL CLASET( 'Full', M, M, CZERO, CONE, Q, M )
*
SRNAMT = 'CGEMQRT'
CALL CGEMQRT( 'L', 'N', M, M, K, NB2_UB, AF, M, T2, NB2, Q, M,
$ WORK, INFO )
*
* Copy R
*
CALL CLASET( 'Full', M, N, CZERO, CZERO, R, M )
*
CALL CLACPY( 'Upper', M, N, AF, M, R, M )
*
* TEST 1
* Compute |R - (Q**H)*A| / ( eps * m * |A| ) and store in RESULT(1)
*
CALL CGEMM( 'C', 'N', M, N, M, -CONE, Q, M, A, M, CONE, R, M )
*
ANORM = CLANGE( '1', M, N, A, M, RWORK )
RESID = CLANGE( '1', M, N, R, M, RWORK )
IF( ANORM.GT.ZERO ) THEN
RESULT( 1 ) = RESID / ( EPS * MAX( 1, M ) * ANORM )
ELSE
RESULT( 1 ) = ZERO
END IF
*
* TEST 2
* Compute |I - (Q**H)*Q| / ( eps * m ) and store in RESULT(2)
*
CALL CLASET( 'Full', M, M, CZERO, CONE, R, M )
CALL CHERK( 'U', 'C', M, M, -CONE, Q, M, CONE, R, M )
RESID = CLANSY( '1', 'Upper', M, R, M, RWORK )
RESULT( 2 ) = RESID / ( EPS * MAX( 1, M ) )
*
* Generate random m-by-n matrix C
*
DO J = 1, N
CALL CLARNV( 2, ISEED, M, C( 1, J ) )
END DO
CNORM = CLANGE( '1', M, N, C, M, RWORK )
CALL CLACPY( 'Full', M, N, C, M, CF, M )
*
* Apply Q to C as Q*C = CF
*
SRNAMT = 'CGEMQRT'
CALL CGEMQRT( 'L', 'N', M, N, K, NB2_UB, AF, M, T2, NB2, CF, M,
$ WORK, INFO )
*
* TEST 3
* Compute |CF - Q*C| / ( eps * m * |C| )
*
CALL CGEMM( 'N', 'N', M, N, M, -CONE, Q, M, C, M, CONE, CF, M )
RESID = CLANGE( '1', M, N, CF, M, RWORK )
IF( CNORM.GT.ZERO ) THEN
RESULT( 3 ) = RESID / ( EPS * MAX( 1, M ) * CNORM )
ELSE
RESULT( 3 ) = ZERO
END IF
*
* Copy C into CF again
*
CALL CLACPY( 'Full', M, N, C, M, CF, M )
*
* Apply Q to C as (Q**H)*C = CF
*
SRNAMT = 'CGEMQRT'
CALL CGEMQRT( 'L', 'C', M, N, K, NB2_UB, AF, M, T2, NB2, CF, M,
$ WORK, INFO )
*
* TEST 4
* Compute |CF - (Q**H)*C| / ( eps * m * |C|)
*
CALL CGEMM( 'C', 'N', M, N, M, -CONE, Q, M, C, M, CONE, CF, M )
RESID = CLANGE( '1', M, N, CF, M, RWORK )
IF( CNORM.GT.ZERO ) THEN
RESULT( 4 ) = RESID / ( EPS * MAX( 1, M ) * CNORM )
ELSE
RESULT( 4 ) = ZERO
END IF
*
* Generate random n-by-m matrix D and a copy DF
*
DO J = 1, M
CALL CLARNV( 2, ISEED, N, D( 1, J ) )
END DO
DNORM = CLANGE( '1', N, M, D, N, RWORK )
CALL CLACPY( 'Full', N, M, D, N, DF, N )
*
* Apply Q to D as D*Q = DF
*
SRNAMT = 'CGEMQRT'
CALL CGEMQRT( 'R', 'N', N, M, K, NB2_UB, AF, M, T2, NB2, DF, N,
$ WORK, INFO )
*
* TEST 5
* Compute |DF - D*Q| / ( eps * m * |D| )
*
CALL CGEMM( 'N', 'N', N, M, M, -CONE, D, N, Q, M, CONE, DF, N )
RESID = CLANGE( '1', N, M, DF, N, RWORK )
IF( DNORM.GT.ZERO ) THEN
RESULT( 5 ) = RESID / ( EPS * MAX( 1, M ) * DNORM )
ELSE
RESULT( 5 ) = ZERO
END IF
*
* Copy D into DF again
*
CALL CLACPY( 'Full', N, M, D, N, DF, N )
*
* Apply Q to D as D*QT = DF
*
SRNAMT = 'CGEMQRT'
CALL CGEMQRT( 'R', 'C', N, M, K, NB2_UB, AF, M, T2, NB2, DF, N,
$ WORK, INFO )
*
* TEST 6
* Compute |DF - D*(Q**H)| / ( eps * m * |D| )
*
CALL CGEMM( 'N', 'C', N, M, M, -CONE, D, N, Q, M, CONE, DF, N )
RESID = CLANGE( '1', N, M, DF, N, RWORK )
IF( DNORM.GT.ZERO ) THEN
RESULT( 6 ) = RESID / ( EPS * MAX( 1, M ) * DNORM )
ELSE
RESULT( 6 ) = ZERO
END IF
*
* Deallocate all arrays
*
DEALLOCATE ( A, AF, Q, R, RWORK, WORK, T1, T2, DIAG,
$ C, D, CF, DF )
*
RETURN
*
* End of CUNHR_COL01
*
END

+ 27
- 12
lapack-netlib/TESTING/LIN/dchkaa.f View File

@@ -68,6 +68,10 @@
*> DEQ *> 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,
$ DCHKQL, DCHKQR, DCHKRQ, DCHKSP, DCHKSY,
$ DCHKSY_ROOK, DCHKSY_RK, DCHKSY_AA, DCHKTB,
$ DCHKTP, DCHKTR, DCHKTZ, DDRVGB, DDRVGE,
$ DDRVGT, DDRVLS, DDRVPB, DDRVPO, DDRVPP,
$ DDRVPT, DDRVSP, DDRVSY, DDRVSY_ROOK, DDRVSY_RK,
$ DDRVSY_AA, ILAVER, DCHKQRT,
$ DCHKQRTP, DCHKLQTP, DCHKTSQR, DCHKLQT

$ DCHKORHR_COL, DCHKPB, DCHKPO, DCHKPS, DCHKPP,
$ DCHKPT, DCHKQ3, DCHKQL, DCHKQR, DCHKRQ, DCHKSP,
$ DCHKSY, DCHKSY_ROOK, DCHKSY_RK, DCHKSY_AA,
$ DCHKTB, DCHKTP, DCHKTR, DCHKTZ, DDRVGB, DDRVGE,
$ DDRVGT, DDRVLS, DDRVPB, DDRVPO, DDRVPP, DDRVPT,
$ DDRVSP, DDRVSY, DDRVSY_ROOK, DDRVSY_RK,
$ DDRVSY_AA, ILAVER, DCHKLQTP, DCHKQRT, DCHKQRTP,
$ DCHKLQT,DCHKTSQR
* .. * ..
* .. Scalars in Common .. * .. 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


+ 239
- 0
lapack-netlib/TESTING/LIN/dchkorhr_col.f View File

@@ -0,0 +1,239 @@
*> \brief \b DCHKORHR_COL
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE DCHKORHR_COL( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
* NBVAL, NOUT )
*
* .. Scalar Arguments ..
* LOGICAL TSTERR
* INTEGER NM, NN, NNB, NOUT
* DOUBLE PRECISION THRESH
* ..
* .. Array Arguments ..
* INTEGER MVAL( * ), NBVAL( * ), NVAL( * )
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DCHKORHR_COL tests DORHR_COL using DLATSQR and DGEMQRT. Therefore, DLATSQR
*> (used in DGEQR) and DGEMQRT (used in DGEMQR) have to be tested
*> before this test.
*>
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] THRESH
*> \verbatim
*> THRESH is DOUBLE PRECISION
*> The threshold value for the test ratios. A result is
*> included in the output file if RESULT >= THRESH. To have
*> every test ratio printed, use THRESH = 0.
*> \endverbatim
*>
*> \param[in] TSTERR
*> \verbatim
*> TSTERR is LOGICAL
*> Flag that indicates whether error exits are to be tested.
*> \endverbatim
*>
*> \param[in] NM
*> \verbatim
*> NM is INTEGER
*> The number of values of M contained in the vector MVAL.
*> \endverbatim
*>
*> \param[in] MVAL
*> \verbatim
*> MVAL is INTEGER array, dimension (NM)
*> The values of the matrix row dimension M.
*> \endverbatim
*>
*> \param[in] NN
*> \verbatim
*> NN is INTEGER
*> The number of values of N contained in the vector NVAL.
*> \endverbatim
*>
*> \param[in] NVAL
*> \verbatim
*> NVAL is INTEGER array, dimension (NN)
*> The values of the matrix column dimension N.
*> \endverbatim
*>
*> \param[in] NNB
*> \verbatim
*> NNB is INTEGER
*> The number of values of NB contained in the vector NBVAL.
*> \endverbatim
*>
*> \param[in] NBVAL
*> \verbatim
*> NBVAL is INTEGER array, dimension (NBVAL)
*> The values of the blocksize NB.
*> \endverbatim
*>
*> \param[in] NOUT
*> \verbatim
*> NOUT is INTEGER
*> The unit number for output.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2019
*
*> \ingroup double_lin
*
* =====================================================================
SUBROUTINE DCHKORHR_COL( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
$ NBVAL, NOUT )
IMPLICIT NONE
*
* -- LAPACK test routine (version 3.7.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* December 2016
*
* .. Scalar Arguments ..
LOGICAL TSTERR
INTEGER NM, NN, NNB, NOUT
DOUBLE PRECISION THRESH
* ..
* .. Array Arguments ..
INTEGER MVAL( * ), NBVAL( * ), NVAL( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
INTEGER NTESTS
PARAMETER ( NTESTS = 6 )
* ..
* .. Local Scalars ..
CHARACTER(LEN=3) PATH
INTEGER I, IMB1, INB1, INB2, J, T, M, N, MB1, NB1,
$ NB2, NFAIL, NERRS, NRUN
*
* .. Local Arrays ..
DOUBLE PRECISION RESULT( NTESTS )
* ..
* .. External Subroutines ..
EXTERNAL ALAHD, ALASUM, DERRORHR_COL, DORHR_COL01
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER(LEN=32) SRNAMT
INTEGER INFOT, NUNIT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, NUNIT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Executable Statements ..
*
* Initialize constants
*
PATH( 1: 1 ) = 'D'
PATH( 2: 3 ) = 'HH'
NRUN = 0
NFAIL = 0
NERRS = 0
*
* Test the error exits
*
IF( TSTERR ) CALL DERRORHR_COL( PATH, NOUT )
INFOT = 0
*
* Do for each value of M in MVAL.
*
DO I = 1, NM
M = MVAL( I )
*
* Do for each value of N in NVAL.
*
DO J = 1, NN
N = NVAL( J )
*
* Only for M >= N
*
IF ( MIN( M, N ).GT.0 .AND. M.GE.N ) THEN
*
* Do for each possible value of MB1
*
DO IMB1 = 1, NNB
MB1 = NBVAL( IMB1 )
*
* Only for MB1 > N
*
IF ( MB1.GT.N ) THEN
*
* Do for each possible value of NB1
*
DO INB1 = 1, NNB
NB1 = NBVAL( INB1 )
*
* Do for each possible value of NB2
*
DO INB2 = 1, NNB
NB2 = NBVAL( INB2 )
*
IF( NB1.GT.0 .AND. NB2.GT.0 ) THEN
*
* Test DORHR_COL
*
CALL DORHR_COL01( M, N, MB1, NB1, NB2,
$ RESULT )
*
* Print information about the tests that did
* not pass the threshold.
*
DO T = 1, NTESTS
IF( RESULT( T ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9999 ) M, N, MB1,
$ NB1, NB2, T, RESULT( T )
NFAIL = NFAIL + 1
END IF
END DO
NRUN = NRUN + NTESTS
END IF
END DO
END DO
END IF
END DO
END IF
END DO
END DO
*
* Print a summary of the results.
*
CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
*
9999 FORMAT( 'M=', I5, ', N=', I5, ', MB1=', I5,
$ ', NB1=', I5, ', NB2=', I5,' test(', I2, ')=', G12.5 )
RETURN
*
* End of DCHKORHR_COL
*
END

+ 8
- 8
lapack-netlib/TESTING/LIN/ddrvls.f View File

@@ -233,8 +233,8 @@
DOUBLE PRECISION EPS, NORMA, NORMB, RCOND DOUBLE PRECISION EPS, NORMA, NORMB, RCOND
* .. * ..
* .. Local Arrays .. * .. Local Arrays ..
INTEGER ISEED( 4 ), ISEEDY( 4 ), IWQ
DOUBLE PRECISION RESULT( NTESTS ), WQ
INTEGER ISEED( 4 ), ISEEDY( 4 ), IWQ( 1 )
DOUBLE PRECISION RESULT( NTESTS ), WQ( 1 )
* .. * ..
* .. Allocatable Arrays .. * .. 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,


+ 164
- 0
lapack-netlib/TESTING/LIN/derrorhr_col.f View File

@@ -0,0 +1,164 @@
*> \brief \b DERRORHR_COL
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE DERRORHR_COL( PATH, NUNIT )
*
* .. Scalar Arguments ..
* CHARACTER*3 PATH
* INTEGER NUNIT
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DERRORHR_COL tests the error exits for DORHR_COL that does
*> Householder reconstruction from the ouput of tall-skinny
*> factorization DLATSQR.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] PATH
*> \verbatim
*> PATH is CHARACTER*3
*> The LAPACK path name for the routines to be tested.
*> \endverbatim
*>
*> \param[in] NUNIT
*> \verbatim
*> NUNIT is INTEGER
*> The unit number for output.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2019
*
*> \ingroup double_lin
*
* =====================================================================
SUBROUTINE DERRORHR_COL( PATH, NUNIT )
IMPLICIT NONE
*
* -- LAPACK test routine (version 3.9.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2019
*
* .. Scalar Arguments ..
CHARACTER(LEN=3) PATH
INTEGER NUNIT
* ..
*
* =====================================================================
*
* .. Parameters ..
INTEGER NMAX
PARAMETER ( NMAX = 2 )
* ..
* .. Local Scalars ..
INTEGER I, INFO, J
* ..
* .. Local Arrays ..
DOUBLE PRECISION A( NMAX, NMAX ), T( NMAX, NMAX ), D(NMAX)
* ..
* .. External Subroutines ..
EXTERNAL ALAESM, CHKXER, DORHR_COL
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER(LEN=32) SRNAMT
INTEGER INFOT, NOUT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, NOUT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE
* ..
* .. Executable Statements ..
*
NOUT = NUNIT
WRITE( NOUT, FMT = * )
*
* Set the variables to innocuous values.
*
DO J = 1, NMAX
DO I = 1, NMAX
A( I, J ) = 1.D+0 / DBLE( I+J )
T( I, J ) = 1.D+0 / DBLE( I+J )
END DO
D( J ) = 0.D+0
END DO
OK = .TRUE.
*
* Error exits for Householder reconstruction
*
* DORHR_COL
*
SRNAMT = 'DORHR_COL'
*
INFOT = 1
CALL DORHR_COL( -1, 0, 1, A, 1, T, 1, D, INFO )
CALL CHKXER( 'DORHR_COL', INFOT, NOUT, LERR, OK )
*
INFOT = 2
CALL DORHR_COL( 0, -1, 1, A, 1, T, 1, D, INFO )
CALL CHKXER( 'DORHR_COL', INFOT, NOUT, LERR, OK )
CALL DORHR_COL( 1, 2, 1, A, 1, T, 1, D, INFO )
CALL CHKXER( 'DORHR_COL', INFOT, NOUT, LERR, OK )
*
INFOT = 3
CALL DORHR_COL( 0, 0, -1, A, 1, T, 1, D, INFO )
CALL CHKXER( 'DORHR_COL', INFOT, NOUT, LERR, OK )
*
CALL DORHR_COL( 0, 0, 0, A, 1, T, 1, D, INFO )
CALL CHKXER( 'DORHR_COL', INFOT, NOUT, LERR, OK )
*
INFOT = 5
CALL DORHR_COL( 0, 0, 1, A, -1, T, 1, D, INFO )
CALL CHKXER( 'DORHR_COL', INFOT, NOUT, LERR, OK )
*
CALL DORHR_COL( 0, 0, 1, A, 0, T, 1, D, INFO )
CALL CHKXER( 'DORHR_COL', INFOT, NOUT, LERR, OK )
*
CALL DORHR_COL( 2, 0, 1, A, 1, T, 1, D, INFO )
CALL CHKXER( 'DORHR_COL', INFOT, NOUT, LERR, OK )
*
INFOT = 7
CALL DORHR_COL( 0, 0, 1, A, 1, T, -1, D, INFO )
CALL CHKXER( 'DORHR_COL', INFOT, NOUT, LERR, OK )
*
CALL DORHR_COL( 0, 0, 1, A, 1, T, 0, D, INFO )
CALL CHKXER( 'DORHR_COL', INFOT, NOUT, LERR, OK )
*
CALL DORHR_COL( 4, 3, 2, A, 4, T, 1, D, INFO )
CALL CHKXER( 'DORHR_COL', INFOT, NOUT, LERR, OK )
*
* Print a summary line.
*
CALL ALAESM( PATH, OK, NOUT )
*
RETURN
*
* End of DERRORHR_COL
*
END

+ 1
- 1
lapack-netlib/TESTING/LIN/derrvx.f View File

@@ -740,7 +740,7 @@
$ W, 1, INFO ) $ 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


+ 386
- 0
lapack-netlib/TESTING/LIN/dorhr_col01.f View File

@@ -0,0 +1,386 @@
*> \brief \b DORHR_COL01
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE DORHR_COL01( M, N, MB1, NB1, NB2, RESULT )
*
* .. Scalar Arguments ..
* INTEGER M, N, MB1, NB1, NB2
* .. Return values ..
* DOUBLE PRECISION RESULT(6)
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DORHR_COL01 tests DORHR_COL using DLATSQR, DGEMQRT and DORGTSQR.
*> Therefore, DLATSQR (part of DGEQR), DGEMQRT (part DGEMQR), DORGTSQR
*> have to be tested before this test.
*>
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> Number of rows in test matrix.
*> \endverbatim
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> Number of columns in test matrix.
*> \endverbatim
*> \param[in] MB1
*> \verbatim
*> MB1 is INTEGER
*> Number of row in row block in an input test matrix.
*> \endverbatim
*>
*> \param[in] NB1
*> \verbatim
*> NB1 is INTEGER
*> Number of columns in column block an input test matrix.
*> \endverbatim
*>
*> \param[in] NB2
*> \verbatim
*> NB2 is INTEGER
*> Number of columns in column block in an output test matrix.
*> \endverbatim
*>
*> \param[out] RESULT
*> \verbatim
*> RESULT is DOUBLE PRECISION array, dimension (6)
*> Results of each of the six tests below.
*> ( C is a M-by-N random matrix, D is a N-by-M random matrix )
*>
*> RESULT(1) = | A - Q * R | / (eps * m * |A|)
*> RESULT(2) = | I - (Q**H) * Q | / (eps * m )
*> RESULT(3) = | Q * C - Q * C | / (eps * m * |C|)
*> RESULT(4) = | (Q**H) * C - (Q**H) * C | / (eps * m * |C|)
*> RESULT(5) = | (D * Q) - D * Q | / (eps * m * |D|)
*> RESULT(6) = | D * (Q**H) - D * (Q**H) | / (eps * m * |D|)
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2019
*
*> \ingroup single_lin
*
* =====================================================================
SUBROUTINE DORHR_COL01( M, N, MB1, NB1, NB2, RESULT )
IMPLICIT NONE
*
* -- LAPACK test routine (version 3.9.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2019
*
* .. Scalar Arguments ..
INTEGER M, N, MB1, NB1, NB2
* .. Return values ..
DOUBLE PRECISION RESULT(6)
*
* =====================================================================
*
* ..
* .. Local allocatable arrays
DOUBLE PRECISION, ALLOCATABLE :: A(:,:), AF(:,:), Q(:,:), R(:,:),
$ RWORK(:), WORK( : ), T1(:,:), T2(:,:), DIAG(:),
$ C(:,:), CF(:,:), D(:,:), DF(:,:)
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL TESTZEROS
INTEGER INFO, I, J, K, L, LWORK, NB1_UB, NB2_UB, NRB
DOUBLE PRECISION ANORM, EPS, RESID, CNORM, DNORM
* ..
* .. Local Arrays ..
INTEGER ISEED( 4 )
DOUBLE PRECISION WORKQUERY( 1 )
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH, DLANGE, DLANSY
EXTERNAL DLAMCH, DLANGE, DLANSY
* ..
* .. External Subroutines ..
EXTERNAL DLACPY, DLARNV, DLASET, DLATSQR, DORHR_COL,
$ DORGTSQR, DSCAL, DGEMM, DGEMQRT, DSYRK
* ..
* .. Intrinsic Functions ..
INTRINSIC CEILING, DBLE, MAX, MIN
* ..
* .. Scalars in Common ..
CHARACTER(LEN=32) SRNAMT
* ..
* .. Common blocks ..
COMMON / SRMNAMC / SRNAMT
* ..
* .. Data statements ..
DATA ISEED / 1988, 1989, 1990, 1991 /
*
* TEST MATRICES WITH HALF OF MATRIX BEING ZEROS
*
TESTZEROS = .FALSE.
*
EPS = DLAMCH( 'Epsilon' )
K = MIN( M, N )
L = MAX( M, N, 1)
*
* Dynamically allocate local arrays
*
ALLOCATE ( A(M,N), AF(M,N), Q(L,L), R(M,L), RWORK(L),
$ C(M,N), CF(M,N),
$ D(N,M), DF(N,M) )
*
* Put random numbers into A and copy to AF
*
DO J = 1, N
CALL DLARNV( 2, ISEED, M, A( 1, J ) )
END DO
IF( TESTZEROS ) THEN
IF( M.GE.4 ) THEN
DO J = 1, N
CALL DLARNV( 2, ISEED, M/2, A( M/4, J ) )
END DO
END IF
END IF
CALL DLACPY( 'Full', M, N, A, M, AF, M )
*
* Number of row blocks in DLATSQR
*
NRB = MAX( 1, CEILING( DBLE( M - N ) / DBLE( MB1 - N ) ) )
*
ALLOCATE ( T1( NB1, N * NRB ) )
ALLOCATE ( T2( NB2, N ) )
ALLOCATE ( DIAG( N ) )
*
* Begin determine LWORK for the array WORK and allocate memory.
*
* DLATSQR requires NB1 to be bounded by N.
*
NB1_UB = MIN( NB1, N)
*
* DGEMQRT requires NB2 to be bounded by N.
*
NB2_UB = MIN( NB2, N)
*
CALL DLATSQR( M, N, MB1, NB1_UB, AF, M, T1, NB1,
$ WORKQUERY, -1, INFO )
LWORK = INT( WORKQUERY( 1 ) )
CALL DORGTSQR( M, N, MB1, NB1, AF, M, T1, NB1, WORKQUERY, -1,
$ INFO )

LWORK = MAX( LWORK, INT( WORKQUERY( 1 ) ) )
*
* In DGEMQRT, WORK is N*NB2_UB if SIDE = 'L',
* or M*NB2_UB if SIDE = 'R'.
*
LWORK = MAX( LWORK, NB2_UB * N, NB2_UB * M )
*
ALLOCATE ( WORK( LWORK ) )
*
* End allocate memory for WORK.
*
*
* Begin Householder reconstruction routines
*
* Factor the matrix A in the array AF.
*
SRNAMT = 'DLATSQR'
CALL DLATSQR( M, N, MB1, NB1_UB, AF, M, T1, NB1, WORK, LWORK,
$ INFO )
*
* Copy the factor R into the array R.
*
SRNAMT = 'DLACPY'
CALL DLACPY( 'U', N, N, AF, M, R, M )
*
* Reconstruct the orthogonal matrix Q.
*
SRNAMT = 'DORGTSQR'
CALL DORGTSQR( M, N, MB1, NB1, AF, M, T1, NB1, WORK, LWORK,
$ INFO )
*
* Perform the Householder reconstruction, the result is stored
* the arrays AF and T2.
*
SRNAMT = 'DORHR_COL'
CALL DORHR_COL( M, N, NB2, AF, M, T2, NB2, DIAG, INFO )
*
* Compute the factor R_hr corresponding to the Householder
* reconstructed Q_hr and place it in the upper triangle of AF to
* match the Q storage format in DGEQRT. R_hr = R_tsqr * S,
* this means changing the sign of I-th row of the matrix R_tsqr
* according to sign of of I-th diagonal element DIAG(I) of the
* matrix S.
*
SRNAMT = 'DLACPY'
CALL DLACPY( 'U', N, N, R, M, AF, M )
*
DO I = 1, N
IF( DIAG( I ).EQ.-ONE ) THEN
CALL DSCAL( N+1-I, -ONE, AF( I, I ), M )
END IF
END DO
*
* End Householder reconstruction routines.
*
*
* Generate the m-by-m matrix Q
*
CALL DLASET( 'Full', M, M, ZERO, ONE, Q, M )
*
SRNAMT = 'DGEMQRT'
CALL DGEMQRT( 'L', 'N', M, M, K, NB2_UB, AF, M, T2, NB2, Q, M,
$ WORK, INFO )
*
* Copy R
*
CALL DLASET( 'Full', M, N, ZERO, ZERO, R, M )
*
CALL DLACPY( 'Upper', M, N, AF, M, R, M )
*
* TEST 1
* Compute |R - (Q**T)*A| / ( eps * m * |A| ) and store in RESULT(1)
*
CALL DGEMM( 'T', 'N', M, N, M, -ONE, Q, M, A, M, ONE, R, M )
*
ANORM = DLANGE( '1', M, N, A, M, RWORK )
RESID = DLANGE( '1', M, N, R, M, RWORK )
IF( ANORM.GT.ZERO ) THEN
RESULT( 1 ) = RESID / ( EPS * MAX( 1, M ) * ANORM )
ELSE
RESULT( 1 ) = ZERO
END IF
*
* TEST 2
* Compute |I - (Q**T)*Q| / ( eps * m ) and store in RESULT(2)
*
CALL DLASET( 'Full', M, M, ZERO, ONE, R, M )
CALL DSYRK( 'U', 'T', M, M, -ONE, Q, M, ONE, R, M )
RESID = DLANSY( '1', 'Upper', M, R, M, RWORK )
RESULT( 2 ) = RESID / ( EPS * MAX( 1, M ) )
*
* Generate random m-by-n matrix C
*
DO J = 1, N
CALL DLARNV( 2, ISEED, M, C( 1, J ) )
END DO
CNORM = DLANGE( '1', M, N, C, M, RWORK )
CALL DLACPY( 'Full', M, N, C, M, CF, M )
*
* Apply Q to C as Q*C = CF
*
SRNAMT = 'DGEMQRT'
CALL DGEMQRT( 'L', 'N', M, N, K, NB2_UB, AF, M, T2, NB2, CF, M,
$ WORK, INFO )
*
* TEST 3
* Compute |CF - Q*C| / ( eps * m * |C| )
*
CALL DGEMM( 'N', 'N', M, N, M, -ONE, Q, M, C, M, ONE, CF, M )
RESID = DLANGE( '1', M, N, CF, M, RWORK )
IF( CNORM.GT.ZERO ) THEN
RESULT( 3 ) = RESID / ( EPS * MAX( 1, M ) * CNORM )
ELSE
RESULT( 3 ) = ZERO
END IF
*
* Copy C into CF again
*
CALL DLACPY( 'Full', M, N, C, M, CF, M )
*
* Apply Q to C as (Q**T)*C = CF
*
SRNAMT = 'DGEMQRT'
CALL DGEMQRT( 'L', 'T', M, N, K, NB2_UB, AF, M, T2, NB2, CF, M,
$ WORK, INFO )
*
* TEST 4
* Compute |CF - (Q**T)*C| / ( eps * m * |C|)
*
CALL DGEMM( 'T', 'N', M, N, M, -ONE, Q, M, C, M, ONE, CF, M )
RESID = DLANGE( '1', M, N, CF, M, RWORK )
IF( CNORM.GT.ZERO ) THEN
RESULT( 4 ) = RESID / ( EPS * MAX( 1, M ) * CNORM )
ELSE
RESULT( 4 ) = ZERO
END IF
*
* Generate random n-by-m matrix D and a copy DF
*
DO J = 1, M
CALL DLARNV( 2, ISEED, N, D( 1, J ) )
END DO
DNORM = DLANGE( '1', N, M, D, N, RWORK )
CALL DLACPY( 'Full', N, M, D, N, DF, N )
*
* Apply Q to D as D*Q = DF
*
SRNAMT = 'DGEMQRT'
CALL DGEMQRT( 'R', 'N', N, M, K, NB2_UB, AF, M, T2, NB2, DF, N,
$ WORK, INFO )
*
* TEST 5
* Compute |DF - D*Q| / ( eps * m * |D| )
*
CALL DGEMM( 'N', 'N', N, M, M, -ONE, D, N, Q, M, ONE, DF, N )
RESID = DLANGE( '1', N, M, DF, N, RWORK )
IF( DNORM.GT.ZERO ) THEN
RESULT( 5 ) = RESID / ( EPS * MAX( 1, M ) * DNORM )
ELSE
RESULT( 5 ) = ZERO
END IF
*
* Copy D into DF again
*
CALL DLACPY( 'Full', N, M, D, N, DF, N )
*
* Apply Q to D as D*QT = DF
*
SRNAMT = 'DGEMQRT'
CALL DGEMQRT( 'R', 'T', N, M, K, NB2_UB, AF, M, T2, NB2, DF, N,
$ WORK, INFO )
*
* TEST 6
* Compute |DF - D*(Q**T)| / ( eps * m * |D| )
*
CALL DGEMM( 'N', 'T', N, M, M, -ONE, D, N, Q, M, ONE, DF, N )
RESID = DLANGE( '1', N, M, DF, N, RWORK )
IF( DNORM.GT.ZERO ) THEN
RESULT( 6 ) = RESID / ( EPS * MAX( 1, M ) * DNORM )
ELSE
RESULT( 6 ) = ZERO
END IF
*
* Deallocate all arrays
*
DEALLOCATE ( A, AF, Q, R, RWORK, WORK, T1, T2, DIAG,
$ C, D, CF, DF )
*
RETURN
*
* End of DORHR_COL01
*
END

+ 13
- 13
lapack-netlib/TESTING/LIN/dtsqr01.f View File

@@ -115,7 +115,7 @@
* .. * ..
* .. Local Arrays .. * .. 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'


+ 24
- 11
lapack-netlib/TESTING/LIN/schkaa.f View File

@@ -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,
$ SCHKQL, SCHKQR, SCHKRQ, SCHKSP, SCHKSY,
$ SCHKSY_ROOK, SCHKSY_RK, SCHKSY_AA, SCHKTB,
$ SCHKTP, SCHKTR, SCHKTZ, SDRVGB, SDRVGE, SDRVGT,
$ SDRVLS, SDRVPB, SDRVPO, SDRVPP, SDRVPT, SDRVSP,
$ SDRVSY, SDRVSY_ROOK, SDRVSY_RK, SDRVSY_AA,
$ ILAVER, SCHKLQTP, SCHKQRT, SCHKQRTP,
$ SCHKORHR_COL, SCHKPB, SCHKPO, SCHKPS, SCHKPP,
$ SCHKPT, SCHKQ3, SCHKQL, SCHKQR, SCHKRQ, SCHKSP,
$ SCHKSY, SCHKSY_ROOK, SCHKSY_RK, SCHKSY_AA,
$ SCHKTB, SCHKTP, SCHKTR, SCHKTZ, SDRVGB, SDRVGE,
$ SDRVGT, SDRVLS, SDRVPB, SDRVPO, SDRVPP, SDRVPT,
$ SDRVSP, SDRVSY, SDRVSY_ROOK, SDRVSY_RK,
$ SDRVSY_AA, ILAVER, SCHKLQTP, SCHKQRT, SCHKQRTP,
$ SCHKLQT, SCHKTSQR $ 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
* *


+ 239
- 0
lapack-netlib/TESTING/LIN/schkorhr_col.f View File

@@ -0,0 +1,239 @@
*> \brief \b SCHKORHR_COL
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE SCHKORHR_COL( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
* NBVAL, NOUT )
*
* .. Scalar Arguments ..
* LOGICAL TSTERR
* INTEGER NM, NN, NNB, NOUT
* REAL THRESH
* ..
* .. Array Arguments ..
* INTEGER MVAL( * ), NBVAL( * ), NVAL( * )
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> SCHKORHR_COL tests SORHR_COL using SLATSQR, SGEMQRT and SORGTSQR.
*> Therefore, SLATSQR (part of SGEQR), SGEMQRT (part SGEMQR), SORGTSQR
*> have to be tested before this test.
*>
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] THRESH
*> \verbatim
*> THRESH is REAL
*> The threshold value for the test ratios. A result is
*> included in the output file if RESULT >= THRESH. To have
*> every test ratio printed, use THRESH = 0.
*> \endverbatim
*>
*> \param[in] TSTERR
*> \verbatim
*> TSTERR is LOGICAL
*> Flag that indicates whether error exits are to be tested.
*> \endverbatim
*>
*> \param[in] NM
*> \verbatim
*> NM is INTEGER
*> The number of values of M contained in the vector MVAL.
*> \endverbatim
*>
*> \param[in] MVAL
*> \verbatim
*> MVAL is INTEGER array, dimension (NM)
*> The values of the matrix row dimension M.
*> \endverbatim
*>
*> \param[in] NN
*> \verbatim
*> NN is INTEGER
*> The number of values of N contained in the vector NVAL.
*> \endverbatim
*>
*> \param[in] NVAL
*> \verbatim
*> NVAL is INTEGER array, dimension (NN)
*> The values of the matrix column dimension N.
*> \endverbatim
*>
*> \param[in] NNB
*> \verbatim
*> NNB is INTEGER
*> The number of values of NB contained in the vector NBVAL.
*> \endverbatim
*>
*> \param[in] NBVAL
*> \verbatim
*> NBVAL is INTEGER array, dimension (NBVAL)
*> The values of the blocksize NB.
*> \endverbatim
*>
*> \param[in] NOUT
*> \verbatim
*> NOUT is INTEGER
*> The unit number for output.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2019
*
*> \ingroup sigle_lin
*
* =====================================================================
SUBROUTINE SCHKORHR_COL( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
$ NBVAL, NOUT )
IMPLICIT NONE
*
* -- LAPACK test routine (version 3.9.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* June 2019
*
* .. Scalar Arguments ..
LOGICAL TSTERR
INTEGER NM, NN, NNB, NOUT
REAL THRESH
* ..
* .. Array Arguments ..
INTEGER MVAL( * ), NBVAL( * ), NVAL( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
INTEGER NTESTS
PARAMETER ( NTESTS = 6 )
* ..
* .. Local Scalars ..
CHARACTER(LEN=3) PATH
INTEGER I, IMB1, INB1, INB2, J, T, M, N, MB1, NB1,
$ NB2, NFAIL, NERRS, NRUN
*
* .. Local Arrays ..
REAL RESULT( NTESTS )
* ..
* .. External Subroutines ..
EXTERNAL ALAHD, ALASUM, SERRORHR_COL, SORHR_COL01
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER(LEN=32) SRNAMT
INTEGER INFOT, NUNIT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, NUNIT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Executable Statements ..
*
* Initialize constants
*
PATH( 1: 1 ) = 'S'
PATH( 2: 3 ) = 'HH'
NRUN = 0
NFAIL = 0
NERRS = 0
*
* Test the error exits
*
IF( TSTERR ) CALL SERRORHR_COL( PATH, NOUT )
INFOT = 0
*
* Do for each value of M in MVAL.
*
DO I = 1, NM
M = MVAL( I )
*
* Do for each value of N in NVAL.
*
DO J = 1, NN
N = NVAL( J )
*
* Only for M >= N
*
IF ( MIN( M, N ).GT.0 .AND. M.GE.N ) THEN
*
* Do for each possible value of MB1
*
DO IMB1 = 1, NNB
MB1 = NBVAL( IMB1 )
*
* Only for MB1 > N
*
IF ( MB1.GT.N ) THEN
*
* Do for each possible value of NB1
*
DO INB1 = 1, NNB
NB1 = NBVAL( INB1 )
*
* Do for each possible value of NB2
*
DO INB2 = 1, NNB
NB2 = NBVAL( INB2 )
*
IF( NB1.GT.0 .AND. NB2.GT.0 ) THEN
*
* Test SORHR_COL
*
CALL SORHR_COL01( M, N, MB1, NB1, NB2,
$ RESULT )
*
* Print information about the tests that did
* not pass the threshold.
*
DO T = 1, NTESTS
IF( RESULT( T ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9999 ) M, N, MB1,
$ NB1, NB2, T, RESULT( T )
NFAIL = NFAIL + 1
END IF
END DO
NRUN = NRUN + NTESTS
END IF
END DO
END DO
END IF
END DO
END IF
END DO
END DO
*
* Print a summary of the results.
*
CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
*
9999 FORMAT( 'M=', I5, ', N=', I5, ', MB1=', I5,
$ ', NB1=', I5, ', NB2=', I5,' test(', I2, ')=', G12.5 )
RETURN
*
* End of SCHKORHR_COL
*
END

+ 10
- 10
lapack-netlib/TESTING/LIN/sdrvls.f View File

@@ -233,8 +233,8 @@
REAL EPS, NORMA, NORMB, RCOND REAL EPS, NORMA, NORMB, RCOND
* .. * ..
* .. Local Arrays .. * .. Local Arrays ..
INTEGER ISEED( 4 ), ISEEDY( 4 ), IWQ
REAL RESULT( NTESTS ), WQ
INTEGER ISEED( 4 ), ISEEDY( 4 ), IWQ( 1 )
REAL RESULT( NTESTS ), WQ( 1 )
* .. * ..
* .. Allocatable Arrays .. * .. 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 )
LWORK_SGELS = INT ( WQ )
$ B, LDB, WQ( 1 ), -1, INFO )
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 )
LWORK_SGETSLS = INT( WQ )
$ B, LDB, WQ( 1 ), -1, INFO )
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,


+ 164
- 0
lapack-netlib/TESTING/LIN/serrorhr_col.f View File

@@ -0,0 +1,164 @@
*> \brief \b SERRORHR_COL
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE SERRORHR_COL( PATH, NUNIT )
*
* .. Scalar Arguments ..
* CHARACTER*3 PATH
* INTEGER NUNIT
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> SERRORHR_COL tests the error exits for SORHR_COL that does
*> Householder reconstruction from the ouput of tall-skinny
*> factorization SLATSQR.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] PATH
*> \verbatim
*> PATH is CHARACTER*3
*> The LAPACK path name for the routines to be tested.
*> \endverbatim
*>
*> \param[in] NUNIT
*> \verbatim
*> NUNIT is INTEGER
*> The unit number for output.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2019
*
*> \ingroup singlr_lin
*
* =====================================================================
SUBROUTINE SERRORHR_COL( PATH, NUNIT )
IMPLICIT NONE
*
* -- LAPACK test routine (version 3.9.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2019
*
* .. Scalar Arguments ..
CHARACTER(LEN=3) PATH
INTEGER NUNIT
* ..
*
* =====================================================================
*
* .. Parameters ..
INTEGER NMAX
PARAMETER ( NMAX = 2 )
* ..
* .. Local Scalars ..
INTEGER I, INFO, J
* ..
* .. Local Arrays ..
REAL A( NMAX, NMAX ), T( NMAX, NMAX ), D(NMAX)
* ..
* .. External Subroutines ..
EXTERNAL ALAESM, CHKXER, SORHR_COL
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER(LEN=32) SRNAMT
INTEGER INFOT, NOUT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, NOUT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Intrinsic Functions ..
INTRINSIC REAL
* ..
* .. Executable Statements ..
*
NOUT = NUNIT
WRITE( NOUT, FMT = * )
*
* Set the variables to innocuous values.
*
DO J = 1, NMAX
DO I = 1, NMAX
A( I, J ) = 1.E+0 / REAL( I+J )
T( I, J ) = 1.E+0 / REAL( I+J )
END DO
D( J ) = 0.E+0
END DO
OK = .TRUE.
*
* Error exits for Householder reconstruction
*
* SORHR_COL
*
SRNAMT = 'SORHR_COL'
*
INFOT = 1
CALL SORHR_COL( -1, 0, 1, A, 1, T, 1, D, INFO )
CALL CHKXER( 'SORHR_COL', INFOT, NOUT, LERR, OK )
*
INFOT = 2
CALL SORHR_COL( 0, -1, 1, A, 1, T, 1, D, INFO )
CALL CHKXER( 'SORHR_COL', INFOT, NOUT, LERR, OK )
CALL SORHR_COL( 1, 2, 1, A, 1, T, 1, D, INFO )
CALL CHKXER( 'SORHR_COL', INFOT, NOUT, LERR, OK )
*
INFOT = 3
CALL SORHR_COL( 0, 0, -1, A, 1, T, 1, D, INFO )
CALL CHKXER( 'SORHR_COL', INFOT, NOUT, LERR, OK )
*
CALL SORHR_COL( 0, 0, 0, A, 1, T, 1, D, INFO )
CALL CHKXER( 'SORHR_COL', INFOT, NOUT, LERR, OK )
*
INFOT = 5
CALL SORHR_COL( 0, 0, 1, A, -1, T, 1, D, INFO )
CALL CHKXER( 'SORHR_COL', INFOT, NOUT, LERR, OK )
*
CALL SORHR_COL( 0, 0, 1, A, 0, T, 1, D, INFO )
CALL CHKXER( 'SORHR_COL', INFOT, NOUT, LERR, OK )
*
CALL SORHR_COL( 2, 0, 1, A, 1, T, 1, D, INFO )
CALL CHKXER( 'SORHR_COL', INFOT, NOUT, LERR, OK )
*
INFOT = 7
CALL SORHR_COL( 0, 0, 1, A, 1, T, -1, D, INFO )
CALL CHKXER( 'SORHR_COL', INFOT, NOUT, LERR, OK )
*
CALL SORHR_COL( 0, 0, 1, A, 1, T, 0, D, INFO )
CALL CHKXER( 'SORHR_COL', INFOT, NOUT, LERR, OK )
*
CALL SORHR_COL( 4, 3, 2, A, 4, T, 1, D, INFO )
CALL CHKXER( 'SORHR_COL', INFOT, NOUT, LERR, OK )
*
* Print a summary line.
*
CALL ALAESM( PATH, OK, NOUT )
*
RETURN
*
* End of SERRORHR_COL
*
END

+ 1
- 1
lapack-netlib/TESTING/LIN/serrvx.f View File

@@ -735,7 +735,7 @@
$ W, 1, INFO ) $ 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


+ 386
- 0
lapack-netlib/TESTING/LIN/sorhr_col01.f View File

@@ -0,0 +1,386 @@
*> \brief \b SORHR_COL01
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE SORHR_COL01( M, N, MB1, NB1, NB2, RESULT)
*
* .. Scalar Arguments ..
* INTEGER M, N, MB1, NB1, NB2
* .. Return values ..
* REAL RESULT(6)
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> SORHR_COL01 tests SORHR_COL using SLATSQR, SGEMQRT and SORGTSQR.
*> Therefore, SLATSQR (part of SGEQR), SGEMQRT (part SGEMQR), SORGTSQR
*> have to be tested before this test.
*>
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> Number of rows in test matrix.
*> \endverbatim
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> Number of columns in test matrix.
*> \endverbatim
*> \param[in] MB1
*> \verbatim
*> MB1 is INTEGER
*> Number of row in row block in an input test matrix.
*> \endverbatim
*>
*> \param[in] NB1
*> \verbatim
*> NB1 is INTEGER
*> Number of columns in column block an input test matrix.
*> \endverbatim
*>
*> \param[in] NB2
*> \verbatim
*> NB2 is INTEGER
*> Number of columns in column block in an output test matrix.
*> \endverbatim
*>
*> \param[out] RESULT
*> \verbatim
*> RESULT is REAL array, dimension (6)
*> Results of each of the six tests below.
*> ( C is a M-by-N random matrix, D is a N-by-M random matrix )
*>
*> RESULT(1) = | A - Q * R | / (eps * m * |A|)
*> RESULT(2) = | I - (Q**H) * Q | / (eps * m )
*> RESULT(3) = | Q * C - Q * C | / (eps * m * |C|)
*> RESULT(4) = | (Q**H) * C - (Q**H) * C | / (eps * m * |C|)
*> RESULT(5) = | (D * Q) - D * Q | / (eps * m * |D|)
*> RESULT(6) = | D * (Q**H) - D * (Q**H) | / (eps * m * |D|)
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2019
*
*> \ingroup single_lin
*
* =====================================================================
SUBROUTINE SORHR_COL01( M, N, MB1, NB1, NB2, RESULT )
IMPLICIT NONE
*
* -- LAPACK test routine (version 3.9.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2019
*
* .. Scalar Arguments ..
INTEGER M, N, MB1, NB1, NB2
* .. Return values ..
REAL RESULT(6)
*
* =====================================================================
*
* ..
* .. Local allocatable arrays
REAL, ALLOCATABLE :: A(:,:), AF(:,:), Q(:,:), R(:,:),
$ RWORK(:), WORK( : ), T1(:,:), T2(:,:), DIAG(:),
$ C(:,:), CF(:,:), D(:,:), DF(:,:)
*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL TESTZEROS
INTEGER INFO, I, J, K, L, LWORK, NB1_UB, NB2_UB, NRB
REAL ANORM, EPS, RESID, CNORM, DNORM
* ..
* .. Local Arrays ..
INTEGER ISEED( 4 )
REAL WORKQUERY( 1 )
* ..
* .. External Functions ..
REAL SLAMCH, SLANGE, SLANSY
EXTERNAL SLAMCH, SLANGE, SLANSY
* ..
* .. External Subroutines ..
EXTERNAL SLACPY, SLARNV, SLASET, SLATSQR, SORHR_COL,
$ SORGTSQR, SSCAL, SGEMM, SGEMQRT, SSYRK
* ..
* .. Intrinsic Functions ..
INTRINSIC CEILING, MAX, MIN, REAL
* ..
* .. Scalars in Common ..
CHARACTER(LEN=32) SRNAMT
* ..
* .. Common blocks ..
COMMON / SRMNAMC / SRNAMT
* ..
* .. Data statements ..
DATA ISEED / 1988, 1989, 1990, 1991 /
*
* TEST MATRICES WITH HALF OF MATRIX BEING ZEROS
*
TESTZEROS = .FALSE.
*
EPS = SLAMCH( 'Epsilon' )
K = MIN( M, N )
L = MAX( M, N, 1)
*
* Dynamically allocate local arrays
*
ALLOCATE ( A(M,N), AF(M,N), Q(L,L), R(M,L), RWORK(L),
$ C(M,N), CF(M,N),
$ D(N,M), DF(N,M) )
*
* Put random numbers into A and copy to AF
*
DO J = 1, N
CALL SLARNV( 2, ISEED, M, A( 1, J ) )
END DO
IF( TESTZEROS ) THEN
IF( M.GE.4 ) THEN
DO J = 1, N
CALL SLARNV( 2, ISEED, M/2, A( M/4, J ) )
END DO
END IF
END IF
CALL SLACPY( 'Full', M, N, A, M, AF, M )
*
* Number of row blocks in SLATSQR
*
NRB = MAX( 1, CEILING( REAL( M - N ) / REAL( MB1 - N ) ) )
*
ALLOCATE ( T1( NB1, N * NRB ) )
ALLOCATE ( T2( NB2, N ) )
ALLOCATE ( DIAG( N ) )
*
* Begin determine LWORK for the array WORK and allocate memory.
*
* SLATSQR requires NB1 to be bounded by N.
*
NB1_UB = MIN( NB1, N)
*
* SGEMQRT requires NB2 to be bounded by N.
*
NB2_UB = MIN( NB2, N)
*
CALL SLATSQR( M, N, MB1, NB1_UB, AF, M, T1, NB1,
$ WORKQUERY, -1, INFO )
LWORK = INT( WORKQUERY( 1 ) )
CALL SORGTSQR( M, N, MB1, NB1, AF, M, T1, NB1, WORKQUERY, -1,
$ INFO )

LWORK = MAX( LWORK, INT( WORKQUERY( 1 ) ) )
*
* In SGEMQRT, WORK is N*NB2_UB if SIDE = 'L',
* or M*NB2_UB if SIDE = 'R'.
*
LWORK = MAX( LWORK, NB2_UB * N, NB2_UB * M )
*
ALLOCATE ( WORK( LWORK ) )
*
* End allocate memory for WORK.
*
*
* Begin Householder reconstruction routines
*
* Factor the matrix A in the array AF.
*
SRNAMT = 'SLATSQR'
CALL SLATSQR( M, N, MB1, NB1_UB, AF, M, T1, NB1, WORK, LWORK,
$ INFO )
*
* Copy the factor R into the array R.
*
SRNAMT = 'SLACPY'
CALL SLACPY( 'U', N, N, AF, M, R, M )
*
* Reconstruct the orthogonal matrix Q.
*
SRNAMT = 'SORGTSQR'
CALL SORGTSQR( M, N, MB1, NB1, AF, M, T1, NB1, WORK, LWORK,
$ INFO )
*
* Perform the Householder reconstruction, the result is stored
* the arrays AF and T2.
*
SRNAMT = 'SORHR_COL'
CALL SORHR_COL( M, N, NB2, AF, M, T2, NB2, DIAG, INFO )
*
* Compute the factor R_hr corresponding to the Householder
* reconstructed Q_hr and place it in the upper triangle of AF to
* match the Q storage format in DGEQRT. R_hr = R_tsqr * S,
* this means changing the sign of I-th row of the matrix R_tsqr
* according to sign of of I-th diagonal element DIAG(I) of the
* matrix S.
*
SRNAMT = 'SLACPY'
CALL SLACPY( 'U', N, N, R, M, AF, M )
*
DO I = 1, N
IF( DIAG( I ).EQ.-ONE ) THEN
CALL SSCAL( N+1-I, -ONE, AF( I, I ), M )
END IF
END DO
*
* End Householder reconstruction routines.
*
*
* Generate the m-by-m matrix Q
*
CALL SLASET( 'Full', M, M, ZERO, ONE, Q, M )
*
SRNAMT = 'SGEMQRT'
CALL SGEMQRT( 'L', 'N', M, M, K, NB2_UB, AF, M, T2, NB2, Q, M,
$ WORK, INFO )
*
* Copy R
*
CALL SLASET( 'Full', M, N, ZERO, ZERO, R, M )
*
CALL SLACPY( 'Upper', M, N, AF, M, R, M )
*
* TEST 1
* Compute |R - (Q**T)*A| / ( eps * m * |A| ) and store in RESULT(1)
*
CALL SGEMM( 'T', 'N', M, N, M, -ONE, Q, M, A, M, ONE, R, M )
*
ANORM = SLANGE( '1', M, N, A, M, RWORK )
RESID = SLANGE( '1', M, N, R, M, RWORK )
IF( ANORM.GT.ZERO ) THEN
RESULT( 1 ) = RESID / ( EPS * MAX( 1, M ) * ANORM )
ELSE
RESULT( 1 ) = ZERO
END IF
*
* TEST 2
* Compute |I - (Q**T)*Q| / ( eps * m ) and store in RESULT(2)
*
CALL SLASET( 'Full', M, M, ZERO, ONE, R, M )
CALL SSYRK( 'U', 'T', M, M, -ONE, Q, M, ONE, R, M )
RESID = SLANSY( '1', 'Upper', M, R, M, RWORK )
RESULT( 2 ) = RESID / ( EPS * MAX( 1, M ) )
*
* Generate random m-by-n matrix C
*
DO J = 1, N
CALL SLARNV( 2, ISEED, M, C( 1, J ) )
END DO
CNORM = SLANGE( '1', M, N, C, M, RWORK )
CALL SLACPY( 'Full', M, N, C, M, CF, M )
*
* Apply Q to C as Q*C = CF
*
SRNAMT = 'SGEMQRT'
CALL SGEMQRT( 'L', 'N', M, N, K, NB2_UB, AF, M, T2, NB2, CF, M,
$ WORK, INFO )
*
* TEST 3
* Compute |CF - Q*C| / ( eps * m * |C| )
*
CALL SGEMM( 'N', 'N', M, N, M, -ONE, Q, M, C, M, ONE, CF, M )
RESID = SLANGE( '1', M, N, CF, M, RWORK )
IF( CNORM.GT.ZERO ) THEN
RESULT( 3 ) = RESID / ( EPS * MAX( 1, M ) * CNORM )
ELSE
RESULT( 3 ) = ZERO
END IF
*
* Copy C into CF again
*
CALL SLACPY( 'Full', M, N, C, M, CF, M )
*
* Apply Q to C as (Q**T)*C = CF
*
SRNAMT = 'SGEMQRT'
CALL SGEMQRT( 'L', 'T', M, N, K, NB2_UB, AF, M, T2, NB2, CF, M,
$ WORK, INFO )
*
* TEST 4
* Compute |CF - (Q**T)*C| / ( eps * m * |C|)
*
CALL SGEMM( 'T', 'N', M, N, M, -ONE, Q, M, C, M, ONE, CF, M )
RESID = SLANGE( '1', M, N, CF, M, RWORK )
IF( CNORM.GT.ZERO ) THEN
RESULT( 4 ) = RESID / ( EPS * MAX( 1, M ) * CNORM )
ELSE
RESULT( 4 ) = ZERO
END IF
*
* Generate random n-by-m matrix D and a copy DF
*
DO J = 1, M
CALL SLARNV( 2, ISEED, N, D( 1, J ) )
END DO
DNORM = SLANGE( '1', N, M, D, N, RWORK )
CALL SLACPY( 'Full', N, M, D, N, DF, N )
*
* Apply Q to D as D*Q = DF
*
SRNAMT = 'SGEMQRT'
CALL SGEMQRT( 'R', 'N', N, M, K, NB2_UB, AF, M, T2, NB2, DF, N,
$ WORK, INFO )
*
* TEST 5
* Compute |DF - D*Q| / ( eps * m * |D| )
*
CALL SGEMM( 'N', 'N', N, M, M, -ONE, D, N, Q, M, ONE, DF, N )
RESID = SLANGE( '1', N, M, DF, N, RWORK )
IF( DNORM.GT.ZERO ) THEN
RESULT( 5 ) = RESID / ( EPS * MAX( 1, M ) * DNORM )
ELSE
RESULT( 5 ) = ZERO
END IF
*
* Copy D into DF again
*
CALL SLACPY( 'Full', N, M, D, N, DF, N )
*
* Apply Q to D as D*QT = DF
*
SRNAMT = 'SGEMQRT'
CALL SGEMQRT( 'R', 'T', N, M, K, NB2_UB, AF, M, T2, NB2, DF, N,
$ WORK, INFO )
*
* TEST 6
* Compute |DF - D*(Q**T)| / ( eps * m * |D| )
*
CALL SGEMM( 'N', 'T', N, M, M, -ONE, D, N, Q, M, ONE, DF, N )
RESID = SLANGE( '1', N, M, DF, N, RWORK )
IF( DNORM.GT.ZERO ) THEN
RESULT( 6 ) = RESID / ( EPS * MAX( 1, M ) * DNORM )
ELSE
RESULT( 6 ) = ZERO
END IF
*
* Deallocate all arrays
*
DEALLOCATE ( A, AF, Q, R, RWORK, WORK, T1, T2, DIAG,
$ C, D, CF, DF )
*
RETURN
*
* End of SORHR_COL01
*
END

+ 13
- 13
lapack-netlib/TESTING/LIN/stsqr01.f View File

@@ -115,7 +115,7 @@
* .. * ..
* .. Local Arrays .. * .. 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'


+ 28
- 15
lapack-netlib/TESTING/LIN/zchkaa.f View File

@@ -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,
$ ZCHKQ3, ZCHKQL, ZCHKQR, ZCHKRQ, ZCHKSP, ZCHKSY,
$ ZCHKSY_ROOK, ZCHKSY_RK, ZCHKSY_AA, ZCHKTB,
$ ZCHKTP, ZCHKTR, ZCHKTZ, ZDRVGB, ZDRVGE, ZDRVGT,
$ ZDRVHE, ZDRVHE_ROOK, ZDRVHE_RK, ZDRVHE_AA,
$ ZDRVHE_AA_2STAGE, ZDRVHP, ZDRVLS, ZDRVPB,
$ ZDRVPO, ZDRVPP, ZDRVPT, ZDRVSP, ZDRVSY,
$ ZDRVSY_ROOK, ZDRVSY_RK, ZDRVSY_AA,
$ ZDRVSY_AA_2STAGE, ILAVER, ZCHKQRT, ZCHKQRTP,
$ ZCHKLQT, ZCHKLQTP, ZCHKTSQR
$ ZCHKLQ, ZCHKUNHR_COL, ZCHKPB, ZCHKPO, ZCHKPS,
$ ZCHKPP, ZCHKPT, ZCHKQ3, ZCHKQL, ZCHKQR, ZCHKRQ,
$ ZCHKSP, ZCHKSY, ZCHKSY_ROOK, ZCHKSY_RK,
$ ZCHKSY_AA, ZCHKTB, ZCHKTP, ZCHKTR, ZCHKTZ,
$ ZDRVGB, ZDRVGE, ZDRVGT, ZDRVHE, ZDRVHE_ROOK,
$ ZDRVHE_RK, ZDRVHE_AA, ZDRVHE_AA_2STAGE, ZDRVHP,
$ ZDRVLS, ZDRVPB, ZDRVPO, ZDRVPP, ZDRVPT,
$ ZDRVSP, ZDRVSY, ZDRVSY_ROOK, ZDRVSY_RK,
$ ZDRVSY_AA, ZDRVSY_AA_2STAGE, ILAVER, ZCHKQRT,
$ ZCHKQRTP, ZCHKLQT, ZCHKLQTP, ZCHKTSQR
* .. * ..
* .. Scalars in Common .. * .. 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
* *


+ 239
- 0
lapack-netlib/TESTING/LIN/zchkunhr_col.f View File

@@ -0,0 +1,239 @@
*> \brief \b ZCHKUNHR_COL
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE ZCHKUNHR_COL( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
* NBVAL, NOUT )
*
* .. Scalar Arguments ..
* LOGICAL TSTERR
* INTEGER NM, NN, NNB, NOUT
* DOUBLE PRECISION THRESH
* ..
* .. Array Arguments ..
* INTEGER MVAL( * ), NBVAL( * ), NVAL( * )
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZCHKUNHR_COL tests ZUNHR_COL using ZLATSQR and ZGEMQRT. Therefore, ZLATSQR
*> (used in ZGEQR) and ZGEMQRT (used in ZGEMQR) have to be tested
*> before this test.
*>
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] THRESH
*> \verbatim
*> THRESH is DOUBLE PRECISION
*> The threshold value for the test ratios. A result is
*> included in the output file if RESULT >= THRESH. To have
*> every test ratio printed, use THRESH = 0.
*> \endverbatim
*>
*> \param[in] TSTERR
*> \verbatim
*> TSTERR is LOGICAL
*> Flag that indicates whether error exits are to be tested.
*> \endverbatim
*>
*> \param[in] NM
*> \verbatim
*> NM is INTEGER
*> The number of values of M contained in the vector MVAL.
*> \endverbatim
*>
*> \param[in] MVAL
*> \verbatim
*> MVAL is INTEGER array, dimension (NM)
*> The values of the matrix row dimension M.
*> \endverbatim
*>
*> \param[in] NN
*> \verbatim
*> NN is INTEGER
*> The number of values of N contained in the vector NVAL.
*> \endverbatim
*>
*> \param[in] NVAL
*> \verbatim
*> NVAL is INTEGER array, dimension (NN)
*> The values of the matrix column dimension N.
*> \endverbatim
*>
*> \param[in] NNB
*> \verbatim
*> NNB is INTEGER
*> The number of values of NB contained in the vector NBVAL.
*> \endverbatim
*>
*> \param[in] NBVAL
*> \verbatim
*> NBVAL is INTEGER array, dimension (NBVAL)
*> The values of the blocksize NB.
*> \endverbatim
*>
*> \param[in] NOUT
*> \verbatim
*> NOUT is INTEGER
*> The unit number for output.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2019
*
*> \ingroup complex16_lin
*
* =====================================================================
SUBROUTINE ZCHKUNHR_COL( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB,
$ NBVAL, NOUT )
IMPLICIT NONE
*
* -- LAPACK test routine (version 3.7.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* December 2016
*
* .. Scalar Arguments ..
LOGICAL TSTERR
INTEGER NM, NN, NNB, NOUT
DOUBLE PRECISION THRESH
* ..
* .. Array Arguments ..
INTEGER MVAL( * ), NBVAL( * ), NVAL( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
INTEGER NTESTS
PARAMETER ( NTESTS = 6 )
* ..
* .. Local Scalars ..
CHARACTER(LEN=3) PATH
INTEGER I, IMB1, INB1, INB2, J, T, M, N, MB1, NB1,
$ NB2, NFAIL, NERRS, NRUN
*
* .. Local Arrays ..
DOUBLE PRECISION RESULT( NTESTS )
* ..
* .. External Subroutines ..
EXTERNAL ALAHD, ALASUM, ZERRUNHR_COL, ZUNHR_COL01
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER(LEN=32) SRNAMT
INTEGER INFOT, NUNIT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, NUNIT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Executable Statements ..
*
* Initialize constants
*
PATH( 1: 1 ) = 'Z'
PATH( 2: 3 ) = 'HH'
NRUN = 0
NFAIL = 0
NERRS = 0
*
* Test the error exits
*
IF( TSTERR ) CALL ZERRUNHR_COL( PATH, NOUT )
INFOT = 0
*
* Do for each value of M in MVAL.
*
DO I = 1, NM
M = MVAL( I )
*
* Do for each value of N in NVAL.
*
DO J = 1, NN
N = NVAL( J )
*
* Only for M >= N
*
IF ( MIN( M, N ).GT.0 .AND. M.GE.N ) THEN
*
* Do for each possible value of MB1
*
DO IMB1 = 1, NNB
MB1 = NBVAL( IMB1 )
*
* Only for MB1 > N
*
IF ( MB1.GT.N ) THEN
*
* Do for each possible value of NB1
*
DO INB1 = 1, NNB
NB1 = NBVAL( INB1 )
*
* Do for each possible value of NB2
*
DO INB2 = 1, NNB
NB2 = NBVAL( INB2 )
*
IF( NB1.GT.0 .AND. NB2.GT.0 ) THEN
*
* Test ZUNHR_COL
*
CALL ZUNHR_COL01( M, N, MB1, NB1, NB2,
$ RESULT )
*
* Print information about the tests that did
* not pass the threshold.
*
DO T = 1, NTESTS
IF( RESULT( T ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9999 ) M, N, MB1,
$ NB1, NB2, T, RESULT( T )
NFAIL = NFAIL + 1
END IF
END DO
NRUN = NRUN + NTESTS
END IF
END DO
END DO
END IF
END DO
END IF
END DO
END DO
*
* Print a summary of the results.
*
CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
*
9999 FORMAT( 'M=', I5, ', N=', I5, ', MB1=', I5,
$ ', NB1=', I5, ', NB2=', I5,' test(', I2, ')=', G12.5 )
RETURN
*
* End of ZCHKUNHR_COL
*
END

+ 1
- 0
lapack-netlib/TESTING/LIN/zdrvhe_rk.f View File

@@ -98,6 +98,7 @@
*> \param[out] E *> \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


+ 13
- 12
lapack-netlib/TESTING/LIN/zdrvls.f View File

@@ -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
DOUBLE PRECISION RESULT( NTESTS ), RWQ
COMPLEX*16 WQ
INTEGER ISEED( 4 ), ISEEDY( 4 ), IWQ( 1 )
DOUBLE PRECISION RESULT( NTESTS ), RWQ( 1 )
COMPLEX*16 WQ( 1 )
* .. * ..
* .. Allocatable Arrays .. * .. 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 )
LRWORK_ZGELSD = INT( RWQ )
LWORK_ZGELSD = INT( WQ( 1 ) )
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.


+ 164
- 0
lapack-netlib/TESTING/LIN/zerrunhr_col.f View File

@@ -0,0 +1,164 @@
*> \brief \b ZERRUNHR_COL
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE ZERRUNHR_COL( PATH, NUNIT )
*
* .. Scalar Arguments ..
* CHARACTER*3 PATH
* INTEGER NUNIT
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZERRUNHR_COL tests the error exits for ZUNHR_COL that does
*> Householder reconstruction from the ouput of tall-skinny
*> factorization ZLATSQR.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] PATH
*> \verbatim
*> PATH is CHARACTER*3
*> The LAPACK path name for the routines to be tested.
*> \endverbatim
*>
*> \param[in] NUNIT
*> \verbatim
*> NUNIT is INTEGER
*> The unit number for output.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2019
*
*> \ingroup complex16_lin
*
* =====================================================================
SUBROUTINE ZERRUNHR_COL( PATH, NUNIT )
IMPLICIT NONE
*
* -- LAPACK test routine (version 3.9.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2019
*
* .. Scalar Arguments ..
CHARACTER(LEN=3) PATH
INTEGER NUNIT
* ..
*
* =====================================================================
*
* .. Parameters ..
INTEGER NMAX
PARAMETER ( NMAX = 2 )
* ..
* .. Local Scalars ..
INTEGER I, INFO, J
* ..
* .. Local Arrays ..
COMPLEX*16 A( NMAX, NMAX ), T( NMAX, NMAX ), D(NMAX)
* ..
* .. External Subroutines ..
EXTERNAL ALAESM, CHKXER, ZUNHR_COL
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER(LEN=32) SRNAMT
INTEGER INFOT, NOUT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, NOUT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, DCMPLX
* ..
* .. Executable Statements ..
*
NOUT = NUNIT
WRITE( NOUT, FMT = * )
*
* Set the variables to innocuous values.
*
DO J = 1, NMAX
DO I = 1, NMAX
A( I, J ) = DCMPLX( 1.D+0 / DBLE( I+J ) )
T( I, J ) = DCMPLX( 1.D+0 / DBLE( I+J ) )
END DO
D( J ) = ( 0.D+0, 0.D+0 )
END DO
OK = .TRUE.
*
* Error exits for Householder reconstruction
*
* ZUNHR_COL
*
SRNAMT = 'ZUNHR_COL'
*
INFOT = 1
CALL ZUNHR_COL( -1, 0, 1, A, 1, T, 1, D, INFO )
CALL CHKXER( 'ZUNHR_COL', INFOT, NOUT, LERR, OK )
*
INFOT = 2
CALL ZUNHR_COL( 0, -1, 1, A, 1, T, 1, D, INFO )
CALL CHKXER( 'ZUNHR_COL', INFOT, NOUT, LERR, OK )
CALL ZUNHR_COL( 1, 2, 1, A, 1, T, 1, D, INFO )
CALL CHKXER( 'ZUNHR_COL', INFOT, NOUT, LERR, OK )
*
INFOT = 3
CALL ZUNHR_COL( 0, 0, -1, A, 1, T, 1, D, INFO )
CALL CHKXER( 'ZUNHR_COL', INFOT, NOUT, LERR, OK )
*
CALL ZUNHR_COL( 0, 0, 0, A, 1, T, 1, D, INFO )
CALL CHKXER( 'ZUNHR_COL', INFOT, NOUT, LERR, OK )
*
INFOT = 5
CALL ZUNHR_COL( 0, 0, 1, A, -1, T, 1, D, INFO )
CALL CHKXER( 'ZUNHR_COL', INFOT, NOUT, LERR, OK )
*
CALL ZUNHR_COL( 0, 0, 1, A, 0, T, 1, D, INFO )
CALL CHKXER( 'ZUNHR_COL', INFOT, NOUT, LERR, OK )
*
CALL ZUNHR_COL( 2, 0, 1, A, 1, T, 1, D, INFO )
CALL CHKXER( 'ZUNHR_COL', INFOT, NOUT, LERR, OK )
*
INFOT = 7
CALL ZUNHR_COL( 0, 0, 1, A, 1, T, -1, D, INFO )
CALL CHKXER( 'ZUNHR_COL', INFOT, NOUT, LERR, OK )
*
CALL ZUNHR_COL( 0, 0, 1, A, 1, T, 0, D, INFO )
CALL CHKXER( 'ZUNHR_COL', INFOT, NOUT, LERR, OK )
*
CALL ZUNHR_COL( 4, 3, 2, A, 4, T, 1, D, INFO )
CALL CHKXER( 'ZUNHR_COL', INFOT, NOUT, LERR, OK )
*
* Print a summary line.
*
CALL ALAESM( PATH, OK, NOUT )
*
RETURN
*
* End of ZERRUNHR_COL
*
END

+ 33
- 3
lapack-netlib/TESTING/LIN/zerrvx.f View File

@@ -94,7 +94,7 @@
$ ZHPSV, ZHPSVX, ZPBSV, ZPBSVX, ZPOSV, ZPOSVX, $ 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


+ 1
- 1
lapack-netlib/TESTING/LIN/zlahilb.f View File

@@ -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)/


+ 13
- 13
lapack-netlib/TESTING/LIN/ztsqr01.f View File

@@ -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'


+ 390
- 0
lapack-netlib/TESTING/LIN/zunhr_col01.f View File

@@ -0,0 +1,390 @@
*> \brief \b ZUNHR_COL01
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE ZUNHR_COL01( M, N, MB1, NB1, NB2, RESULT )
*
* .. Scalar Arguments ..
* INTEGER M, N, MB1, NB1, NB2
* .. Return values ..
* DOUBLE PRECISION RESULT(6)
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZUNHR_COL01 tests ZUNHR_COL using ZLATSQR, ZGEMQRT and ZUNGTSQR.
*> Therefore, ZLATSQR (part of ZGEQR), ZGEMQRT (part ZGEMQR), ZUNGTSQR
*> have to be tested before this test.
*>
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> Number of rows in test matrix.
*> \endverbatim
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> Number of columns in test matrix.
*> \endverbatim
*> \param[in] MB1
*> \verbatim
*> MB1 is INTEGER
*> Number of row in row block in an input test matrix.
*> \endverbatim
*>
*> \param[in] NB1
*> \verbatim
*> NB1 is INTEGER
*> Number of columns in column block an input test matrix.
*> \endverbatim
*>
*> \param[in] NB2
*> \verbatim
*> NB2 is INTEGER
*> Number of columns in column block in an output test matrix.
*> \endverbatim
*>
*> \param[out] RESULT
*> \verbatim
*> RESULT is DOUBLE PRECISION array, dimension (6)
*> Results of each of the six tests below.
*> ( C is a M-by-N random matrix, D is a N-by-M random matrix )
*>
*> RESULT(1) = | A - Q * R | / (eps * m * |A|)
*> RESULT(2) = | I - (Q**H) * Q | / (eps * m )
*> RESULT(3) = | Q * C - Q * C | / (eps * m * |C|)
*> RESULT(4) = | (Q**H) * C - (Q**H) * C | / (eps * m * |C|)
*> RESULT(5) = | (D * Q) - D * Q | / (eps * m * |D|)
*> RESULT(6) = | D * (Q**H) - D * (Q**H) | / (eps * m * |D|)
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2019
*
*> \ingroup complex16_lin
*
* =====================================================================
SUBROUTINE ZUNHR_COL01( M, N, MB1, NB1, NB2, RESULT )
IMPLICIT NONE
*
* -- LAPACK test routine (version 3.9.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2019
*
* .. Scalar Arguments ..
INTEGER M, N, MB1, NB1, NB2
* .. Return values ..
DOUBLE PRECISION RESULT(6)
*
* =====================================================================
*
* ..
* .. Local allocatable arrays
COMPLEX*16, ALLOCATABLE :: A(:,:), AF(:,:), Q(:,:), R(:,:),
$ WORK( : ), T1(:,:), T2(:,:), DIAG(:),
$ C(:,:), CF(:,:), D(:,:), DF(:,:)
DOUBLE PRECISION, ALLOCATABLE :: RWORK(:)
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D+0 )
COMPLEX*16 CONE, CZERO
PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ),
$ CZERO = ( 0.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
LOGICAL TESTZEROS
INTEGER INFO, I, J, K, L, LWORK, NB1_UB, NB2_UB, NRB
DOUBLE PRECISION ANORM, EPS, RESID, CNORM, DNORM
* ..
* .. Local Arrays ..
INTEGER ISEED( 4 )
COMPLEX*16 WORKQUERY( 1 )
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH, ZLANGE, ZLANSY
EXTERNAL DLAMCH, ZLANGE, ZLANSY
* ..
* .. External Subroutines ..
EXTERNAL ZLACPY, ZLARNV, ZLASET, ZLATSQR, ZUNHR_COL,
$ ZUNGTSQR, ZSCAL, ZGEMM, ZGEMQRT, ZHERK
* ..
* .. Intrinsic Functions ..
INTRINSIC CEILING, DBLE, MAX, MIN
* ..
* .. Scalars in Common ..
CHARACTER(LEN=32) SRNAMT
* ..
* .. Common blocks ..
COMMON / SRMNAMC / SRNAMT
* ..
* .. Data statements ..
DATA ISEED / 1988, 1989, 1990, 1991 /
*
* TEST MATRICES WITH HALF OF MATRIX BEING ZEROS
*
TESTZEROS = .FALSE.
*
EPS = DLAMCH( 'Epsilon' )
K = MIN( M, N )
L = MAX( M, N, 1)
*
* Dynamically allocate local arrays
*
ALLOCATE ( A(M,N), AF(M,N), Q(L,L), R(M,L), RWORK(L),
$ C(M,N), CF(M,N),
$ D(N,M), DF(N,M) )
*
* Put random numbers into A and copy to AF
*
DO J = 1, N
CALL ZLARNV( 2, ISEED, M, A( 1, J ) )
END DO
IF( TESTZEROS ) THEN
IF( M.GE.4 ) THEN
DO J = 1, N
CALL ZLARNV( 2, ISEED, M/2, A( M/4, J ) )
END DO
END IF
END IF
CALL ZLACPY( 'Full', M, N, A, M, AF, M )
*
* Number of row blocks in ZLATSQR
*
NRB = MAX( 1, CEILING( DBLE( M - N ) / DBLE( MB1 - N ) ) )
*
ALLOCATE ( T1( NB1, N * NRB ) )
ALLOCATE ( T2( NB2, N ) )
ALLOCATE ( DIAG( N ) )
*
* Begin determine LWORK for the array WORK and allocate memory.
*
* ZLATSQR requires NB1 to be bounded by N.
*
NB1_UB = MIN( NB1, N)
*
* ZGEMQRT requires NB2 to be bounded by N.
*
NB2_UB = MIN( NB2, N)
*
CALL ZLATSQR( M, N, MB1, NB1_UB, AF, M, T1, NB1,
$ WORKQUERY, -1, INFO )
LWORK = INT( WORKQUERY( 1 ) )
CALL ZUNGTSQR( M, N, MB1, NB1, AF, M, T1, NB1, WORKQUERY, -1,
$ INFO )

LWORK = MAX( LWORK, INT( WORKQUERY( 1 ) ) )
*
* In ZGEMQRT, WORK is N*NB2_UB if SIDE = 'L',
* or M*NB2_UB if SIDE = 'R'.
*
LWORK = MAX( LWORK, NB2_UB * N, NB2_UB * M )
*
ALLOCATE ( WORK( LWORK ) )
*
* End allocate memory for WORK.
*
*
* Begin Householder reconstruction routines
*
* Factor the matrix A in the array AF.
*
SRNAMT = 'ZLATSQR'
CALL ZLATSQR( M, N, MB1, NB1_UB, AF, M, T1, NB1, WORK, LWORK,
$ INFO )
*
* Copy the factor R into the array R.
*
SRNAMT = 'ZLACPY'
CALL ZLACPY( 'U', M, N, AF, M, R, M )
*
* Reconstruct the orthogonal matrix Q.
*
SRNAMT = 'ZUNGTSQR'
CALL ZUNGTSQR( M, N, MB1, NB1, AF, M, T1, NB1, WORK, LWORK,
$ INFO )
*
* Perform the Householder reconstruction, the result is stored
* the arrays AF and T2.
*
SRNAMT = 'ZUNHR_COL'
CALL ZUNHR_COL( M, N, NB2, AF, M, T2, NB2, DIAG, INFO )
*
* Compute the factor R_hr corresponding to the Householder
* reconstructed Q_hr and place it in the upper triangle of AF to
* match the Q storage format in ZGEQRT. R_hr = R_tsqr * S,
* this means changing the sign of I-th row of the matrix R_tsqr
* according to sign of of I-th diagonal element DIAG(I) of the
* matrix S.
*
SRNAMT = 'ZLACPY'
CALL ZLACPY( 'U', M, N, R, M, AF, M )
*
DO I = 1, N
IF( DIAG( I ).EQ.-CONE ) THEN
CALL ZSCAL( N+1-I, -CONE, AF( I, I ), M )
END IF
END DO
*
* End Householder reconstruction routines.
*
*
* Generate the m-by-m matrix Q
*
CALL ZLASET( 'Full', M, M, CZERO, CONE, Q, M )
*
SRNAMT = 'ZGEMQRT'
CALL ZGEMQRT( 'L', 'N', M, M, K, NB2_UB, AF, M, T2, NB2, Q, M,
$ WORK, INFO )
*
* Copy R
*
CALL ZLASET( 'Full', M, N, CZERO, CZERO, R, M )
*
CALL ZLACPY( 'Upper', M, N, AF, M, R, M )
*
* TEST 1
* Compute |R - (Q**H)*A| / ( eps * m * |A| ) and store in RESULT(1)
*
CALL ZGEMM( 'C', 'N', M, N, M, -CONE, Q, M, A, M, CONE, R, M )
*
ANORM = ZLANGE( '1', M, N, A, M, RWORK )
RESID = ZLANGE( '1', M, N, R, M, RWORK )
IF( ANORM.GT.ZERO ) THEN
RESULT( 1 ) = RESID / ( EPS * MAX( 1, M ) * ANORM )
ELSE
RESULT( 1 ) = ZERO
END IF
*
* TEST 2
* Compute |I - (Q**H)*Q| / ( eps * m ) and store in RESULT(2)
*
CALL ZLASET( 'Full', M, M, CZERO, CONE, R, M )
CALL ZHERK( 'U', 'C', M, M, -CONE, Q, M, CONE, R, M )
RESID = ZLANSY( '1', 'Upper', M, R, M, RWORK )
RESULT( 2 ) = RESID / ( EPS * MAX( 1, M ) )
*
* Generate random m-by-n matrix C
*
DO J = 1, N
CALL ZLARNV( 2, ISEED, M, C( 1, J ) )
END DO
CNORM = ZLANGE( '1', M, N, C, M, RWORK )
CALL ZLACPY( 'Full', M, N, C, M, CF, M )
*
* Apply Q to C as Q*C = CF
*
SRNAMT = 'ZGEMQRT'
CALL ZGEMQRT( 'L', 'N', M, N, K, NB2_UB, AF, M, T2, NB2, CF, M,
$ WORK, INFO )
*
* TEST 3
* Compute |CF - Q*C| / ( eps * m * |C| )
*
CALL ZGEMM( 'N', 'N', M, N, M, -CONE, Q, M, C, M, CONE, CF, M )
RESID = ZLANGE( '1', M, N, CF, M, RWORK )
IF( CNORM.GT.ZERO ) THEN
RESULT( 3 ) = RESID / ( EPS * MAX( 1, M ) * CNORM )
ELSE
RESULT( 3 ) = ZERO
END IF
*
* Copy C into CF again
*
CALL ZLACPY( 'Full', M, N, C, M, CF, M )
*
* Apply Q to C as (Q**H)*C = CF
*
SRNAMT = 'ZGEMQRT'
CALL ZGEMQRT( 'L', 'C', M, N, K, NB2_UB, AF, M, T2, NB2, CF, M,
$ WORK, INFO )
*
* TEST 4
* Compute |CF - (Q**H)*C| / ( eps * m * |C|)
*
CALL ZGEMM( 'C', 'N', M, N, M, -CONE, Q, M, C, M, CONE, CF, M )
RESID = ZLANGE( '1', M, N, CF, M, RWORK )
IF( CNORM.GT.ZERO ) THEN
RESULT( 4 ) = RESID / ( EPS * MAX( 1, M ) * CNORM )
ELSE
RESULT( 4 ) = ZERO
END IF
*
* Generate random n-by-m matrix D and a copy DF
*
DO J = 1, M
CALL ZLARNV( 2, ISEED, N, D( 1, J ) )
END DO
DNORM = ZLANGE( '1', N, M, D, N, RWORK )
CALL ZLACPY( 'Full', N, M, D, N, DF, N )
*
* Apply Q to D as D*Q = DF
*
SRNAMT = 'ZGEMQRT'
CALL ZGEMQRT( 'R', 'N', N, M, K, NB2_UB, AF, M, T2, NB2, DF, N,
$ WORK, INFO )
*
* TEST 5
* Compute |DF - D*Q| / ( eps * m * |D| )
*
CALL ZGEMM( 'N', 'N', N, M, M, -CONE, D, N, Q, M, CONE, DF, N )
RESID = ZLANGE( '1', N, M, DF, N, RWORK )
IF( DNORM.GT.ZERO ) THEN
RESULT( 5 ) = RESID / ( EPS * MAX( 1, M ) * DNORM )
ELSE
RESULT( 5 ) = ZERO
END IF
*
* Copy D into DF again
*
CALL ZLACPY( 'Full', N, M, D, N, DF, N )
*
* Apply Q to D as D*QT = DF
*
SRNAMT = 'ZGEMQRT'
CALL ZGEMQRT( 'R', 'C', N, M, K, NB2_UB, AF, M, T2, NB2, DF, N,
$ WORK, INFO )
*
* TEST 6
* Compute |DF - D*(Q**H)| / ( eps * m * |D| )
*
CALL ZGEMM( 'N', 'C', N, M, M, -CONE, D, N, Q, M, CONE, DF, N )
RESID = ZLANGE( '1', N, M, DF, N, RWORK )
IF( DNORM.GT.ZERO ) THEN
RESULT( 6 ) = RESID / ( EPS * MAX( 1, M ) * DNORM )
ELSE
RESULT( 6 ) = ZERO
END IF
*
* Deallocate all arrays
*
DEALLOCATE ( A, AF, Q, R, RWORK, WORK, T1, T2, DIAG,
$ C, D, CF, DF )
*
RETURN
*
* End of ZUNHR_COL01
*
END

Write Preview
Loading…
Cancel
Save